Access の 名簿データをExcelへ出力 RSSフィード
 


挨拶・自己紹介:失敗続きのAB型の変わり者 三流プログラマー Ken3です。
(※[三流君 三流プログラマーとは?自己紹介や経歴ほか])

Ken3のひとりグループです
・[ken3独りグループのトップページ]へ戻る
・独り言の[掲示板を覗く]
・勝手に作成した[キーワード一覧]を見る
・いつまでも[ken3memo下書き日記]を見る
(一人寂しくグループウェアを使っていたり....(笑))


リスト表示 | ツリー表示

1ken3memoken3memo   Access の 名簿データをExcelへ出力

やりたいこと。

Accessを使って、

名簿を作りたい。

複数取得している資格や特技をサブデータとして独立して管理したい

データを既存のExcelファイルに出力したい(全てのデータと選択したデータ)

なんて、言われたら、

どうしましょうかねぇ?

今、現在の状況を聞きたいよね。

紙で管理しているのか?、それとも既にExcel上で電子データとして管理されているのか?

えっ、これからVBA,マクロの練習を兼ねて作りたいって?

う~ん、困ったなぁ。

(既存のシステムを参考にして、うまく立ち回ろうとしたのに、、、)


泥縄式 システム開発の始まり、はじまり、、

2009-12-08 追加処理 → http://ken3hitori.g.hatena.ne.jp/bbs/2/28?fromtreemode=1

2009-12-21 追加処理 http://ken3hitori.g.hatena.ne.jp/bbs/2/34 で、単票に出力する処理を追加しました。

返信2009/12/22 23:38:09

2ken3memoken3memo   1  1.データの洗い出し

1.データの洗い出し

まずは、必要なデータを洗い出しますか。

社員基本情報

社員番号

氏名

ふりがな

性別

生年月日

郵便番号

住所

電話番号

本籍

配偶者有無

雇用年月日

主な資格・特技

↑問題の資格、手書きの書き方は、、、

シスアド とか 初級システムアドミニストレータ

これって、書き方が違うだけで、同じ資格ですよね。

電子データ化する時に統一しないとなぁ。

普通免許 と 普通自動車免許 も 同じか。

データがバラバラですね。

それと、複数資格を記入しているので、これを分けないとなぁ。

(マスター作れと言われる感じかなぁ、フリーの何でも書けるほうが便利な場合もあるけど。)

返信2009/11/29 10:01:22

3ken3memoken3memo   1  2.センスを問われるテーブル設計

2.センスを問われるテーブル設計

まぁ、場数を踏めば、、慣れてくるんだけど、テーブルを設計します。

ポイントは、資格・特技のマスター作りかなぁ。

テーブルイメージ

f:id:ken3memo:20091117083742j:image

テストのデータイメージ

f:id:ken3memo:20091117083741j:image

返信2009/11/29 10:03:51

4ken3memoken3memo   1  3.Access テーブルを作成します

3.Access テーブルを作成します

テーブルの設計が終了したら、

Accessを開き、テーブルを3つ作成します。

f:id:ken3memo:20091117161112j:image

作成した、モラッタ、テーブル仕様書を見て打ち込みます。

(まぁ、設計に穴があると、項目の過不足とか出てくるんだけど。)

余談・蛇足の操作解説

http://www.youtube.com/watch?v=XdWV-UQ843c

↑Access2003でテーブルを作成するときに、Excelにテストデータを書いておき貼り付ける。

そんな方法です。

まぁ、打ち込んでもいいんだけど、先輩がExcel仕様書を書いていたらコピーしてしまう、そんな方法です。

オートナンバー型の変更がチョット面倒ですが、おおワクをコピーしてから編集の方が楽なので、いつもこんな感じでテーブルを作ってます。

↓ここまでのサンプルファイルです。

[file:ken3memo:Test1124.zip]

↑Access2003とExcel2003のテストファイルが入ってます。

返信2009/11/29 10:19:05

5ken3memoken3memo   1  4.入力画面を作ります

4.入力画面を作ります

テーブルが完成したら、入力画面を作ります。

楽して、ウィザードを使って、入力フォームを作成してみます。

f:id:ken3memo:20091117185135j:image

返信2009/11/29 10:25:55

6ken3memoken3memo   5  4.1 資格マスター 入力画面の作成

4.1 資格マスター 入力画面の作成

テーブル 資格マスター に対して、

下記のような一覧形式でメンテナンス画面を作成します。

(フォーム名:F資格マスター)

資格マスター メンテナンス(←タイトル、少し大きな文字で)

資格ID	分類    資格名称       ← ヘッダー(見出し)
  9    [XXXXX]  [XXXXXXXXXXXX] ← 一覧形式で表示、入力
  9    [XXXXX]  [XXXXXXXXXXXX]
  9    [XXXXX]  [XXXXXXXXXXXX]
                 ↑入力
    ↑入力エリア(ソートする・分類順に並べ替える)
↑表示のみ(オートナンバー型なので。)

操作の動画を貼る

http://www.youtube.com/watch?v=E5JfEhCgGgY

返信2009/11/29 10:27:04

7ken3memoken3memo   6  4.1.1 資格IDを表示のみにする

4.1.1 資格IDを表示のみにする

資格IDを表示のみにしたいので(カーソルを行かなくしたいので)

使用可能 いいえ (いいえにすると表示が消えそうな感じだけど)

編集ロック はい (オートナンバーで元々値を変更できないけど)

↑にプロパティを変更します。

f:id:ken3memo:20091117185134j:image

返信2009/11/29 10:28:25

8ken3memoken3memo   6  4.1.2 分類でソート(並べ替え)

4.1.2 分類でソート(並べ替え)

分類順にしたいので、レコードソースをテーブル指定から少し細工して、並べ替えの指示を追加します。

フォームを選択後、プロパティを選択します。

次に コントロールソースの横の...を押します。

f:id:ken3memo:20091117185133j:image

するとクエリービルダーが起動します。

起動したら、項目を3つ表示させ、

並べ替えで[分類]を昇順にします。

f:id:ken3memo:20091117185132j:image

すると、下記のようにコントロールソースに作成したSQL(クエリー)が代入されます。

f:id:ken3memo:20091117185131j:image

SELECT 資格マスター.資格ID, 資格マスター.資格名称, 資格マスター.分類 FROM 資格マスター ORDER BY 資格マスター.分類;

他にも、ソート・並べ替えの方法ありますが、こんな感じで作成しました。

返信2009/11/29 10:30:47

9ken3memoken3memo   5  4.2 社員テーブル 単票形式の入力画面を作成

4.2 社員テーブル 単票形式の入力画面を作成

さてと、次は、社員テープルの入力フォームの作成です。

このフォームは、

単票形式にして、

+サブフォームで取得した資格を一覧表示・入力可能とします。

4.2.1~4.2.3までの作業動画

[動画を貼り付ける]

http://www.youtube.com/watch?v=gdS_oGW3ox0

返信2009/11/29 10:47:25

10ken3memoken3memo   9  4.2.1 サブフォーム用に資格入力フォームを作成

4.2.1 サブフォーム用に資格入力フォームを作成

メインのフォームを作る前に、サブフォームを作成します。

フォーム名称: SF資格入力 として、

資格取得テーブルを元にして、

ウィザードから表形式を選択し、簡単に作りました。

返信2009/11/29 10:48:54

11ken3memoken3memo   9  4.2.2 メインフォームを単票形式で作成

4.2.2 メインフォームを単票形式で作成

次にメインフォームを作ります。

フォーム名称: F社員入力 として、

社員テーブルを元にして、

ウイザードから単票形式を選択して、簡単に作ります。

返信2009/11/29 10:50:23

12ken3memoken3memo   9  4.2.3 メインフォームにサブフォームを貼り付ける

4.2.3 メインフォームにサブフォームを貼り付ける

メインとサブができあがったので、フォームを貼り付けます。

※社員番号で連結させます。

返信2009/11/29 10:54:41

13ken3memoken3memo   9  4.2.4 サブフォーム 資格IDの選択をコンボボックスにする

4.2.4 サブフォーム 資格IDの選択をコンボボックスにする

資格の選択をマスターから行いたいので、

コンボボックスを使用して選択するように変更します。

4.2.4の作業動画

[動画を貼り付ける]

http://www.youtube.com/watch?v=DZId-6b6f_U


まずは、テキストボックスをコンボボックスに変更します。


次に、コンボボックスの元となる値がほしいので、

値集合ソースに資格マスターから値を取得するSQLを書きます

(事前に用意したクエリーでもいいんだけど)


直接、スラスラとSQL文が書けないので、(書ける人は書いてOKです)

右端の[...]を押して、クエリービルダを使用します。


資格ID,資格名称,分類の3つを表示項目に指定して、分類で並べ替えます。


設定後、×で閉じると、更新するか聞いてくるので、はいを選択します。


すると、クエリービルダーで作成されたSQLが無事に値集合ソースに入ります。

列数を3にすると、3つの項目が無事に表示されます。

次に、小細工したいのが選択後に資格名称が表示されていると便利なので、

列幅を0cm;3cm;1cmとセミコロン区切りで3つ指定します。

↑ポイントは、左端IDを0cmにして、消す、そんな感じです。(姑息だけど)

実行してもらうとわかりやすいんだけど、

値は連結列の1番目がセットされ、

表示は2番目の名称、

そんなコンボボックスが完成します。

返信2009/11/29 10:58:43

14ken3memoken3memo   1  5.AccessのデータをExcelへ転記する

5.AccessのデータをExcelへ転記する

まだまだ、穴があり、改良の余地がある入力画面をほっといて(おいおい)

次は、データをExcelに書き出してみたいと思います。

操作の動画↓

http://www.youtube.com/watch?v=TRRc_fDH1Xk

返信2009/11/29 11:00:59

15ken3memoken3memo   14  5.1 Excel ひな型(テンプレート)ファイルの用意

5.1 Excel ひな型(テンプレート)ファイルの用意

まず、罫線付き、フォーマットが整ったExcelファイルを用意します。

(※白紙から作る方法もありますが、今回は事前に準備します。)

f:id:ken3memo:20091124013755j:image

↑テンプレート.xls として、作成します。

返信2009/11/29 11:01:49

16ken3memoken3memo   14  5.2 AccessからExcelを起動します(ウイザードで楽に作ります)

5.2 AccessからExcelを起動します(ウイザードで楽に作ります)

次にAccessからExcelを起動します。

ここでは、ウィザードを利用して作ってみます。

f:id:ken3memo:20091124013754j:image

↑まぁ、普通にボタンを選択するとウィザードが立ち上がるので、

 アプリケーション -- Excelの起動

 を選択します。

すると、下記のコードが自動的に作成されます。

Private Sub コマンド0_Click()
On Error GoTo Err_コマンド0_Click

    Dim oApp As Object

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

Exit_コマンド0_Click:
    Exit Sub

Err_コマンド0_Click:
    MsgBox Err.Description
    Resume Exit_コマンド0_Click
    
End Sub

返信2009/11/29 11:03:43

17ken3memoken3memo   14  5.3 作成済みのひな型(テンプレート)ファイルを開きます

5.3 作成済みのひな型(テンプレート)ファイルを開きます

まず、Excel側でマクロを記録します。

ツール -- マクロ -- 新しいマクロの記録 を選択します。

f:id:ken3memo:20091124013753j:image

次に、ファイル -- 開く で 先ほど作成した テンプレート.xlsを開きます。

開いたら、マクロの記録を終了させます。

f:id:ken3memo:20091124013752j:image

作成されたマクロ(Excel VBA)を確認するには、

ツール -- マクロ -- Visual Basic Editor を選択します。

(alt+F11キーでもOKです。)

標準モジュールにマクロが作成されています。

Option Explicit

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/11/24  ユーザー名 : user2000
'

'
    ChDir "E:\WORK"
    Workbooks.Open Filename:="E:\WORK\テンプレート.xls"
End Sub

f:id:ken3memo:20091124013751j:image

↑作成された.xlsファイルを開くマクロ(VBAの命令)↓をコピーします

Workbooks.Open Filename:="E:\WORK\テンプレート.xls"

Access側に戻り、

記録したマクロ(コピーしたマクロ)をAccess側に貼り付けます。

頭にExcel参照用の変数 ここではoAppを付けます。

Option Compare Database
Option Explicit

Private Sub コマンド0_Click()
On Error GoTo Err_コマンド0_Click

    Dim oApp As Object

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    oApp.Workbooks.Open Filename:="E:\WORK\テンプレート.xls"
    '↑頭にoAppAccessからExcelを参照する変数を付ける

Exit_コマンド0_Click:
    Exit Sub

Err_コマンド0_Click:
    MsgBox Err.Description
    Resume Exit_コマンド0_Click
    
End Sub

Excelを閉じ、Accessのボタンを押してテストします。

無事にひな型(テンプレート)が開かれたことを確認します。

返信2009/11/29 11:06:35

18ken3memoken3memo   14  5.4 データの転記 ひな型(テンプレート)にデータを流し込みます

5.4 データの転記 ひな型(テンプレート)にデータを流し込みます

やっと、データの転記処理です。

返信2009/11/29 11:12:08

19ken3memoken3memo   18  5.4.1 ファイルの位置をCurrentDb.Nameから抜き出す

5.4.1 ファイルの位置をCurrentDb.Nameから抜き出す

と、その前に、

oApp.Workbooks.Open Filename:="E:\WORK\テンプレート.xls"

だと、E:\WORK\とフォルダー・ディレクトリの場所が固定なので、

手前味噌の No.007 MDBと同フォルダのExcelファイルを開く

http://www.ken3.org/vba/backno/vba007.html

を参考にして、

Private Sub コマンド0_Click()
On Error GoTo Err_コマンド0_Click

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls
    
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE



Exit_コマンド0_Click:
    Exit Sub

Err_コマンド0_Click:
    MsgBox Err.Description
    Resume Exit_コマンド0_Click
    
End Sub

CurrentDb.Name から 現在のフルパスを取り、パスを抜き出して、"テンプレート.xls"と合わせてみました。

strXLSFILEが無事に作成されたら、

おまけで、Dir関数を使用して、ファイルの存在チェックも行い、

oApp.Workbooks.Open Filename:=strXLSFILE

で、開きました。

返信2009/11/29 11:13:19

20ken3memoken3memo   18  5.4.2 社員テーブルから全てのデータを抜き出しセットする

5.4.2 社員テーブルから全てのデータを抜き出しセットする

手前味噌のNo.093 Access2000 ADOでクエリーのレコードを参照 Excelへ出力

http://www.ken3.org/vba/backno/vba093.html

を参考にして、データをセットしてみます。

Dim rs As New ADODB.Recordset

で変数を1つ作成して、

rs.Open "select * from 社員テーブル;", CurrentProject.Connection, _

adOpenKeyset, adLockOptimistic

で、レコードセットを作ります(開きます)

あとは、.EOFのループで

'ループ処理

While rs.EOF = False 'いつものEOFが偽の間

MsgBox "氏名は" & rs.Fields("氏名") '氏名をテストで表示する

rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑)

Wend

rs.Fields("フィールド名")で、データを取り出せるので、

oApp.cells(行, 列) = rs.Fields("氏名")

みたいな感じで、セットします。

http://www.youtube.com/watch?v=Bs-J-51DEt0

[動画を貼る]

↓データセットまでのソース

Option Compare Database
Option Explicit

Private Sub コマンド0_Click()
On Error GoTo Err_コマンド0_Click

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls
    
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です
    
    rs.Open "select * from 社員テーブル;", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    y = 4  '4行目からセットします。
    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        oApp.cells(y, "C") = rs.Fields("生年月日")
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。※後で作成する。
               
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?


Exit_コマンド0_Click:
    Exit Sub

Err_コマンド0_Click:
    MsgBox Err.Description
    Resume Exit_コマンド0_Click
    
End Sub
返信2009/11/29 11:16:34

21ken3memoken3memo   18  5.4.3 社員番号を使用して、資格取得テーブルからデータを抜き出しセットする

5.4.3 社員番号を使用して、資格取得テーブルからデータを抜き出しセットする

社員テーブルのデータを単純にセットする・・・(そんなに単純じゃないけど)

まで、なんとか動いたので、

次は、個人の持っている資格データをH列にセットしてみます。

資格の名前を取り出したいので、

資格取得テーブルと資格名称をつなげたクエリー

クエリー名:Q資格

を1つ作ります。

次に、Q資格から一致する社員番号を取り出すサブ関数を作成します。

'社員番号を受け取り、持っている資格名称を返すサブ関数
Private Function get資格(社員番号 As String) As String

    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"

    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    While rs.EOF = False  'いつものEOFが偽の間
        strRET = strRET & rs.Fields("資格名称") & " "
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

    get資格 = strRET  '作成した変数を返す

End Function

あとは、上位の関数で

'H列に持っている資格複数をセットする。

oApp.cells(y, "H") = get資格(rs.Fields("社員番号"))

↑みたいに、rs.Fields("社員番号")を渡して、資格名称を受け取り、セットします。

作成手順の動画

http://www.youtube.com/watch?v=3jYbUgntzm4

[動画を貼る]

↓ここまでのサンプルファイルです。

http://d.hatena.ne.jp/ken3memo/files/Test1128.zip

↑Access2003とExcel2003のテストファイルが入ってます。

返信2009/11/29 11:41:16

22ken3memoken3memo   14  5.5 選択したデータをExcelへ転記(代入)したい

5.5 選択したデータをExcelへ転記(代入)したい

全てのデータを印刷する処理もまだまだ中途半端なのに、

選択したデータを印刷にチャレンジしてみます。

[動画を貼る。]5.5.1~5.5.2まで

http://www.youtube.com/watch?v=uzCIrvDLOd0

返信2009/11/29 11:25:39

23ken3memoken3memo   22  5.5.1 テーブルに印刷フラグを追加する

5.5.1 テーブルに印刷フラグを追加する

印刷したいデータを選んでもらいたいので、

社員テーブルに印刷フラグを追加します。

フィールド名称は 印刷FLG で Yes/No型の選択型にします。

返信2009/11/29 11:27:40

24ken3memoken3memo   22  5.5.2 印刷データの選択フォームを作ります

5.5.2 印刷データの選択フォームを作ります

次に、印刷したいデータを選択する(ユーザー)に選ばせるフォームを作ります。

フォーム名を F社員選択 として、一覧形式のフォームで作成します。

あとは、印刷FLGが立っているデータを選択したいので、

select * from 社員テーブル where 印刷FLG=Yes

SQLのwhere句で条件に 印刷FLG=Yes を指定しただけです。

Option Compare Database
Option Explicit

Private Sub コマンド10_Click()

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です
  
  '印刷FLGがYesのデータを集める。
    rs.Open "select * from 社員テーブル where 印刷FLG=Yes", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
                                
    If rs.RecordCount = 0 Then '選択件数のチェック
        MsgBox "転送データが選択されていません。"
        Exit Sub  '↑メッセージを表示して関数を抜ける
    End If

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
                                
  'AccessのデータをExcelへ代入する。
    'ループ処理
    y = 4  '4行目からセットします。
    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        oApp.cells(y, "C") = rs.Fields("生年月日")
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。
        oApp.cells(y, "H") = get資格(rs.Fields("社員番号"))
         
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

End Sub

'社員番号を受け取り、持っている資格名称を返すサブ関数
Private Function get資格(社員番号 As String) As String

    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"

    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            strRET = strRET & rs.Fields("資格名称") & " "
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

    get資格 = strRET  '作成した変数を返す

End Function

で、簡単に作るとバグが多くて困りますねぇ。

問題点

1.Excelへ出力を繰り返すことができる(まぁ、これはこれでいいのかも)

  でも、転記後、ひな型ファイルを保存することができる。(壊すことができる)

処置・対策は → http://d.hatena.ne.jp/ken3memo/20091128/1259368613

2.ひな型(テンプレート)ファイルの罫線が引かれていない場所にも転送される。

データ数が多いと、テンプレートの枠を越えます。

  ワクを事前に大きく取ると今度は少量のデータ転送時に困ってしまう。

  データの数に合わせて、罫線を作ってほしい。

処置・対策は → http://d.hatena.ne.jp/ken3memo/20091128/1259398153

3.印刷FLGにチェック後すぐにExcelへのボタンを押すと、

最後にチェックしたデータが転記されない

(テーブルの印刷FLGが更新されていないのでは?)

処置・対策は → http://d.hatena.ne.jp/ken3memo/20091128/1259406486

↓ここまでのやりかけのファイル、解凍して使ってみてください。

http://d.hatena.ne.jp/ken3memo/files/Test1128.zip

↑Access2003のdb1128.mdbとテンプレート.xlsが入ってます

返信2009/11/29 11:42:55

25ken3memoken3memo   24  5.5.2.1 ひな型(テンプレート)ファイルを開いた後にコピーする

5.5.2.1 ひな型(テンプレート)ファイルを開いた後にコピーする

問題点

1.Excelへ出力を繰り返すことができる(まぁ、これはこれでいいのかも)

  でも、転記後、ひな型ファイルを保存することができる。(壊すことができる)

↑に対応するために、

ひな型(テンプレート)ファイルを開いた後にコピーする。

そんな処理にチャレンジしてみたいと思います。

処置として、

一つの案が、テンプレートにデータを流し込んでから、

そのまま保存すると白紙のひな型(テンプレート)が汚れてしまうので、

ひな型(テンプレート)、元のxlsファイルを開いたらすぐに、

シートのコピー 新規のブック で 新しいブックにコピーします。

で、ひな型(テンプレート)は何もしないで閉じる、そんな処理を追加してみます。

f:id:ken3memo:20091128093624j:image

まずは、Excelで操作のマクロを記録します。

マクロ記録で

ア.シートを右クリック、移動またはコピーを選択

イ.新規ブック と □コピーにチェックを入れる。

ウ.新規ブックにコピーされるので、元のテンプレートに戻ります(ウインドウで選択)

エ.テンプレート.xlsを閉じます。

上記マクロを記録すると、

Option Explicit

Sub Macro4()
'
' Macro4 Macro
' マクロ記録日 : 2009/11/28  ユーザー名 : user2000
'

'
    Windows("テンプレート.xls").Activate
    Sheets("名簿").Select
    Sheets("名簿").Copy
    Windows("テンプレート.xls").Activate
    ActiveWorkbook.Close
End Sub

と記録されます。

あとは、このマクロAccessへ移植します。

と言っても、貼り付けて、頭に参照用の変数 oApp を付けただけです。

f:id:ken3memo:20091128093623j:image

    oApp.Windows("テンプレート.xls").Activate
    oApp.Sheets("名簿").Select
    oApp.Sheets("名簿").Copy
    oApp.Windows("テンプレート.xls").Activate
    oApp.ActiveWorkbook.Close

↑の挿入位置は、テンプレート.xlsを開いた後に入れました。

Private Sub コマンド10_Click()

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です
  
  '印刷FLGがYesのデータを集める。
    rs.Open "select * from 社員テーブル where 印刷FLG=Yes", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
                                
    If rs.RecordCount = 0 Then '選択件数のチェック
        MsgBox "転送データが選択されていません。"
        Exit Sub  '↑メッセージを表示して関数を抜ける
    End If

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE

    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート.xls").Activate
    oApp.Sheets("名簿").Select
    oApp.Sheets("名簿").Copy
    oApp.Windows("テンプレート.xls").Activate
    oApp.ActiveWorkbook.Close

                                
  'AccessのデータをExcelへ代入する。
    'ループ処理
    y = 4  '4行目からセットします。
    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        oApp.cells(y, "C") = rs.Fields("生年月日")
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。
        oApp.cells(y, "H") = get資格(rs.Fields("社員番号"))
         
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

End Sub

これで、テンプレートファイルを誤って壊される心配も無くなりました。。。

操作手順とテストの動画

[動画を貼り付ける。]

http://www.youtube.com/watch?v=0pAGQdCZTgc

返信2009/11/29 11:31:23

26ken3memoken3memo   24  5.5.2.2 罫線などの書式を最後の行までコピーする

5.5.2.2 罫線などの書式を最後の行までコピーする

問題点

2.ひな型(テンプレート)ファイルの罫線が引かれていない場所にも転送される。

データ数が多いと、テンプレートの枠を越えます。

  ワクを事前に大きく取ると今度は少量のデータ転送時に困ってしまう。

  データの数に合わせて、罫線を作ってほしい。

対策・処置として、

頭の行(4行・5行目の書式)をコピーして、

データ数分だけ書式を貼り付ける

そんな処理で対応してみたいと思います。

f:id:ken3memo:20091128174800j:image

そんな操作・動作をマクロ記録すると、下記のように記録されます。

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/11/28  ユーザー名 : user2000
'

'
    Rows("4:5").Select
    Range("B4").Activate
    Selection.Copy
    Rows("6:21").Select
    Range("B6").Activate
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A4:A5").Select
End Sub

まぁ、余計なコードも付いていますが、これをAccessへ貼り付けます。

と、同時に、

Set oApp = CreateObject("Excel.Application")

などで起動しているので、頭に変数oApp.を付け

oApp.Rows("4:5").Select

oApp.Range("B4").Activate

oApp.Selection.Copy

oApp.Rows("6:" & y - 1).Select

oApp.Range("B6").Activate

oApp.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

oApp.Application.CutCopyMode = False

oApp.Range("A4:A5").Select

みたいな感じで貼り付けます。

で、テスト実行すると、

えっ、コンパイルエラー 変数が定義されてません。

ガクッ、xlPasteFormats が定義されていないと、怒られコンパイルエラーで止まります。

f:id:ken3memo:20091128174759j:image

oApp.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

xlPasteFormatsxlNoneExcel側のVBA,定数なので、

Accessでは定義されていないとエラーになってしまいます。

(冷静に考えれば、xlXXXXxlが頭に付いたExcel側の定数なので。)

原因が、定数が定義されていないので、定数を使わない方法があります。

※定数をExcel側で書き出し直接値を書きます。

書き出す方法は、ExcelVBAのイミディエイト ウインドウで

f:id:ken3memo:20091128174758j:image

? xlPasteFormats

  • 4122

? hex(xlPasteFormats)

FFFFEFE6

? hex(xlNone)

FFFFEFD2

と、? xl定数 や ? hex(xl定数) で16進数で値を表示させ、AccesのVBAに書き込みます。

oApp.Selection.PasteSpecial Paste:=&HFFFFEFE6, Operation:=&HFFFFEFD2, _

SkipBlanks:=False, Transpose:=False

↑こんな感じで、格好悪いけど、直接値を書き込みます。(&Hで16進数です。)

完成したソース(長いけど・・・)

Private Sub コマンド10_Click()

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です
  
  '印刷FLGがYesのデータを集める。
    rs.Open "select * from 社員テーブル where 印刷FLG=Yes", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
                                
    If rs.RecordCount = 0 Then '選択件数のチェック
        MsgBox "転送データが選択されていません。"
        Exit Sub  '↑メッセージを表示して関数を抜ける
    End If

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート.xls").Activate
    oApp.Sheets("名簿").Select
    oApp.Sheets("名簿").Copy
    oApp.Windows("テンプレート.xls").Activate
    oApp.ActiveWorkbook.Close

                                
  'AccessのデータをExcelへ代入する。
    'ループ処理
    y = 4  '4行目からセットします。
    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        oApp.cells(y, "C") = rs.Fields("生年月日")
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。
        oApp.cells(y, "H") = get資格(rs.Fields("社員番号"))
         
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

  '書式の調整
    'データの終わり、y-1まで、書式(罫線など)をコピーする
    oApp.Rows("4:5").Select
    oApp.Range("B4").Activate
    oApp.Selection.Copy
    oApp.Rows("6:" & y - 1).Select
    oApp.Range("B6").Activate
    oApp.Selection.PasteSpecial Paste:=&HFFFFEFE6, Operation:=&HFFFFEFD2, _
        SkipBlanks:=False, Transpose:=False
    oApp.Application.CutCopyMode = False
    oApp.Range("A4:A5").Select

End Sub

まぁ、無事に完成したけど、Excelの定数を調べて直接値を毎回書くって変だよね。

それに、Excelの定数なのでめったに値の変更しないかもしれないけど・・・

まぁ、まぁ、そんなに怒らないでくださいよ。

普通のプログラマーさん達は、参照設定を行いますから。

Accessのツール・参照設定から、

Excel XX.X Object Library

を選択します。

f:id:ken3memo:20091128174757j:image

↑参照設定すると、あら不思議、

oApp.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

で、普通にExcel VBAの定数が使えたりします。

参照設定する方法がスマート、自然ですよねぇ。。。

※まぁ、ExcelAccessのバージョン問題などで、

 公開用のソースでは使っていなかったりで、

Const xlPasteFormats = &HFFFFEFE6

Const xlNone = &HFFFFEFD2

とか、定数をConstで頭に書いている(直接の値は書きたくない後でコードの意味がわからなくなる)、そんな対応を取っている人もいると思います。

イロイロあった、試行錯誤・失敗の動作は↓を見てください。

操作・テストの動画をはる

http://www.youtube.com/watch?v=HCp_hUbe-Zg

返信2009/11/29 11:32:53

27ken3memoken3memo   24  5.5.2.3 問題点:チェックボックスのチェックを取りこぼす

5.5.2.3 問題点:チェックボックスのチェックを取りこぼす

問題点

3.印刷FLGにチェック後すぐにExcelへのボタンを押すと、

最後にチェックしたデータが転記されない

(テーブルの印刷FLGが更新されていないのでは?)

原因が、レコードが確定していなかったので、

強制的に・明示的にフォームのチェック、フラグを確定させます。

処置方法は簡単で、1行頭に

Me.Refresh '.Refreshでフォームを更新する(フラグ更新)を強制的に(明示的に)行う

.Refreshの命令を書くだけです。

テストと結果の動画 動画を貼る

http://www.youtube.com/watch?v=L17G53gbTBs

ソースコードは下記を見てください(1行しか追加していないけど・・・)

Option Compare Database
Option Explicit

Private Sub コマンド10_Click()

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です

    Me.Refresh  '.Refreshでフォームを更新する(フラグ更新)を強制的に(明示的に)行う

  '印刷FLGがYesのデータを集める。
    rs.Open "select * from 社員テーブル where 印刷FLG=Yes", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
                                
    If rs.RecordCount = 0 Then '選択件数のチェック
        MsgBox "転送データが選択されていません。"
        Exit Sub  '↑メッセージを表示して関数を抜ける
    End If

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート.xls").Activate
    oApp.Sheets("名簿").Select
    oApp.Sheets("名簿").Copy
    oApp.Windows("テンプレート.xls").Activate
    oApp.ActiveWorkbook.Close
                                
  'AccessのデータをExcelへ代入する。
    'ループ処理
    y = 4  '4行目からセットします。
    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        oApp.cells(y, "C") = rs.Fields("生年月日")
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。
        oApp.cells(y, "H") = get資格(rs.Fields("社員番号"))
         
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

  '書式の調整
    Const xlPasteFormats = &HFFFFEFE6  '参照設定していないので、
    Const xlNone = &HFFFFEFD2          '定数固定値として同じ名前で定義
    'データの終わり、y-1まで、書式(罫線など)をコピーする
    oApp.Rows("4:5").Copy   '基準となる1件目をコピーする(4行目・5行目)
    oApp.Rows("6:" & y - 1).Select  'データの範囲を6行目から選択
    oApp.Range("B6").Activate
    '書式だけを貼り付ける。(Paste:=xlPasteFormatsを指定する)
    oApp.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    oApp.Application.CutCopyMode = False
    oApp.Range("A4").Select  '書式のコピー終了後、カーソルを先頭へ・・・

End Sub

'社員番号を受け取り、持っている資格名称を返すサブ関数
Private Function get資格(社員番号 As String) As String

    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"

    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            strRET = strRET & rs.Fields("資格名称") & " "
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

    get資格 = strRET  '作成した変数を返す

End Function
返信2009/11/29 11:34:26

28ken3memoken3memo   12/08 修正・追加 Accessの名簿データをExcelへ

2009-12-08 問い合わせ、修正処理

12/08に行った、修正です。

1.年齢の表示、Excelへの出力(代入)

2.同じような3つのマスター項目を管理したい

3.印刷FLGの全てにチェックを入れる/チェックを外す

3.1 単純にクエリーを作りボタンで実行した

3.2 チェックボックスの値が変わったら、FLG更新のSQLを実行する

返信2009/12/09 05:52:58

29ken3memoken3memo   28  1208修正・追加 1.年齢の表示、Excelへの出力(代入)

1208修正・追加 1.年齢の表示、Excelへの出力(代入)

>年齢はどういう風に表示したらよろしいでしょうか?フォーム上では

>

>=IIf(Format([生年月日],"mm/dd")>Format(Date(),"mm/dd"),DateDiff("yyyy",[生年月日],Date())-1,DateDiff("yyyy",[生年月日],Date())) & "才"

>

>で出してます、それをコピーして貼り付けたら赤く表示された。

年齢は、

フォーム上(F社員入力)では

>=IIf(Format([生年月日],"mm/dd")>Format(Date(),"mm/dd"),DateDiff("yyyy",[生年月日],Date())-1,DateDiff("yyyy",[生年月日],Date())) & "才"

で、できるなら、

ポイントがフォームだと

[生年月日]

↑これを、レコードセットrsなので、

セル = IIf(Format(rs.Fields("生年月日"),"mm/dd")>Format(Date(),"mm/dd"),DateDiff("yyyy",rs.Fields("生年月日"),Date())-1,DateDiff("yyyy",rs.Fields("生年月日"),Date())) & "才"

とrs.Fields("生年月日")に置き換えるとか?

長くなるので、

Dim yyyymmdd as date

yyyymmdd = rs.Fields("生年月日")

=IIf(Format(yyyymmdd,"mm/dd")>Format(Date(),"mm/dd"),DateDiff("yyyy",yyyymmdd,Date())-1,DateDiff("yyyy",yyyymmdd,Date())) & "才"

と変数に一回入れて、その後 IIfでもいいのかなぁ?

下記のような感じで、作成してみました。

Private Sub コマンド10_Click()

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です

    Me.Refresh  '.Refreshでフォームを更新する(フラグ更新)を強制的に(明示的に)行う

  '印刷FLGがYesのデータを集める。
    rs.Open "select * from 社員テーブル where 印刷FLG=Yes", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
                                
    If rs.RecordCount = 0 Then '選択件数のチェック
        MsgBox "転送データが選択されていません。"
        Exit Sub  '↑メッセージを表示して関数を抜ける
    End If

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート.xls").Activate
    oApp.Sheets("名簿").Select
    oApp.Sheets("名簿").Copy
    oApp.Windows("テンプレート.xls").Activate
    oApp.ActiveWorkbook.Close
                                
  'AccessのデータをExcelへ代入する。
    'ループ処理
    y = 4  '4行目からセットします。
    Dim yyyymmdd As Date   '生年月日を一時的に入れておく変数

    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        yyyymmdd = rs.Fields("生年月日")  '変数に代入してから↓で計算してみる
        oApp.cells(y, "C") = IIf(Format(yyyymmdd, "mm/dd") > Format(Date, "mm/dd"), DateDiff("yyyy", yyyymmdd, Date) - 1, DateDiff("yyyy", yyyymmdd, Date)) & "才"
        
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。
        oApp.cells(y, "H") = get資格(rs.Fields("社員番号"))
         
        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

  '書式の調整
    Const xlPasteFormats = &HFFFFEFE6  '参照設定していないので、
    Const xlNone = &HFFFFEFD2          '定数固定値として同じ名前で定義
    'データの終わり、y-1まで、書式(罫線など)をコピーする
    oApp.Rows("4:5").Copy   '基準となる1件目をコピーする(4行目・5行目)
    oApp.Rows("6:" & y - 1).Select  'データの範囲を6行目から選択
    oApp.Range("B6").Activate
    '書式だけを貼り付ける。(Paste:=xlPasteFormatsを指定する)
    oApp.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    oApp.Application.CutCopyMode = False
    oApp.Range("A4").Select  '書式のコピー終了後、カーソルを先頭へ・・・

End Sub

修正場所は変数定義(Dim yyyymmdd As Date)を入れても3行かなぁ。

yyyymmdd = rs.Fields("生年月日") '変数に代入してから↓で計算してみる

oApp.cells(y, "C") = IIf(Format(yyyymmdd, "mm/dd") > Format(Date, "mm/dd"), DateDiff("yyyy", yyyymmdd, Date) - 1, DateDiff("yyyy", yyyymmdd, Date)) & "才"

※コントロールソースだと、ムリしてIIfを使って1行に書かないとダメですが、

yyyymmdd = rs.Fields("生年月日")
If(Format(yyyymmdd, "mm/dd") > Format(Date, "mm/dd") Then
    str年齢 = DateDiff("yyyy", yyyymmdd, Date) - 1
Else
    str年齢 = DateDiff("yyyy", yyyymmdd, Date)) & "才"
End If
oApp.cells(y, "C") = str年齢  '↑上で計算した年齢を代入

普通にIf文を使うでも、いいとおもいます。お好きな方で・・・処理してください。

試行錯誤の動画を貼る

http://www.youtube.com/watch?v=s-T3jEuz7LA


今回の問い合わせ2009-12-08の分は

http://ken3hitori.g.hatena.ne.jp/bbs/2/28?mode=tree

のツリーを見てください。

全体の開発の流れを見るには

http://ken3hitori.g.hatena.ne.jp/bbs/2?mode=tree

のツリーを見てください。

サンプルファイルは

http://d.hatena.ne.jp/ken3memo/files/Test20091208.zip

を保存して使ってみてください。

返信2009/12/09 06:18:15

30ken3memoken3memo   28  1208修正・追加 2.同じような3つのマスター項目を管理したい

1208修正・追加 2.同じような3つのマスター項目を管理したい

世の中には、会社の数分だけ社員名簿がある、じゃなくって、

イロイロとカスタマイズ?に挑戦してみます。

>資格は免許とかその他や技能と別れてまして、

>テーブルの資格もわけないといけないでしょうか?

f:id:ken3memo:20091209055802j:image

資格教育テーブル

資格資格テーブル

資格免許テーブル

と分けると、面倒なので、

免許とか教育は

資格テーブルに 教育,資格,免許,を1,2,3とかA,B,Cとか、区分を入力しておいて、

strSQL = "select * from Q資格"

strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"

strSQL = strSQL & " And 区分='C'" 'Cの区分のみ

など、で切り替えて引っぱってくるのがいいのかなぁ。

※テーブルを新たに作ると大変なので、

資格名称テーブルに 区分 を追加して、

A教育,B資格,C免許

資格ID 名称 ..... 区分

1 普通免許 C

2 シスアド B

3 PC操作講習 A

にして、

社員番号 と 区分を渡して、3回取ってくるとか?

oApp.cells(y, "列") = get資格(rs.Fields("社員番号"),"A") '教育

oApp.cells(y, "列") = get資格(rs.Fields("社員番号"),"B") '資格

oApp.cells(y, "列") = get資格(rs.Fields("社員番号"),"C") '免許

※すでに分類があったので、使っていない分類を使用します(ぉぃぉぃ)


またまた、修正箇所が少ないですが、下記のような感じで修正しました。

※忘れずにデータ転記先のテンプレート.xls も 教育,資格,免許の3つワクを作ります。

Option Compare Database
Option Explicit

Private Sub コマンド10_Click()

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

    Dim rs As New ADODB.Recordset  'ADOのレコードセットです。
    Dim y As Integer  'セットする行番号です

    Me.Refresh  '.Refreshでフォームを更新する(フラグ更新)を強制的に(明示的に)行う

  '印刷FLGがYesのデータを集める。
    rs.Open "select * from 社員テーブル where 印刷FLG=Yes", CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
                                
    If rs.RecordCount = 0 Then '選択件数のチェック
        MsgBox "転送データが選択されていません。"
        Exit Sub  '↑メッセージを表示して関数を抜ける
    End If

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート.xls").Activate
    oApp.Sheets("名簿").Select
    oApp.Sheets("名簿").Copy
    oApp.Windows("テンプレート.xls").Activate
    oApp.ActiveWorkbook.Close
                                
  'AccessのデータをExcelへ代入する。
    'ループ処理
    y = 4  '4行目からセットします。
    Dim yyyymmdd As Date   '生年月日を一時的に入れておく変数

    While rs.EOF = False  'いつものEOFが偽の間
        
        oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。
        
        oApp.cells(y, "B") = rs.Fields("氏名")
        oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1
        
        yyyymmdd = rs.Fields("生年月日")  '変数に代入してから↓で計算してみる
        oApp.cells(y, "C") = IIf(Format(yyyymmdd, "mm/dd") > Format(Date, "mm/dd"), DateDiff("yyyy", yyyymmdd, Date) - 1, DateDiff("yyyy", yyyymmdd, Date)) & "才"
        
        oApp.cells(y + 1, "C") = rs.Fields("性別")
        
        oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所")
        
        oApp.cells(y, "E") = rs.Fields("電話番号")
        oApp.cells(y + 1, "E") = rs.Fields("本籍")
        
        oApp.cells(y, "F") = rs.Fields("配偶者有無")

        oApp.cells(y, "G") = rs.Fields("雇用年月日")
      
        'H列に持っている資格複数をセットする。
        oApp.cells(y, "H") = get資格(rs.Fields("社員番号"), "A")
        oApp.cells(y, "I") = get資格(rs.Fields("社員番号"), "B")
        oApp.cells(y, "J") = get資格(rs.Fields("社員番号"), "C")

        rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        y = y + 2    '1つの名簿データで2行使うので、+2で次の行です
    Wend

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

  '書式の調整
    Const xlPasteFormats = &HFFFFEFE6  '参照設定していないので、
    Const xlNone = &HFFFFEFD2          '定数固定値として同じ名前で定義
    'データの終わり、y-1まで、書式(罫線など)をコピーする
    oApp.Rows("4:5").Copy   '基準となる1件目をコピーする(4行目・5行目)
    oApp.Rows("6:" & y - 1).Select  'データの範囲を6行目から選択
    oApp.Range("B6").Activate
    '書式だけを貼り付ける。(Paste:=xlPasteFormatsを指定する)
    oApp.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    oApp.Application.CutCopyMode = False
    oApp.Range("A4").Select  '書式のコピー終了後、カーソルを先頭へ・・・

End Sub

'社員番号を受け取り、持っている資格名称を返すサブ関数
Private Function get資格(社員番号 As String, 分類 As String) As String

    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"
    strSQL = strSQL & " And 分類='" & 分類 & "'"  '分類を指定
    
    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            strRET = strRET & rs.Fields("資格名称") & " "
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

    get資格 = strRET  '作成した変数を返す

End Function

試行錯誤の動画ファイルを貼る

http://www.youtube.com/watch?v=S1EyRHjwP1Q


今回の問い合わせ2009-12-08の分は

http://ken3hitori.g.hatena.ne.jp/bbs/2/28?mode=tree

のツリーを見てください。

全体の開発の流れを見るには

http://ken3hitori.g.hatena.ne.jp/bbs/2?mode=tree

のツリーを見てください。

サンプルファイルは

http://d.hatena.ne.jp/ken3memo/files/Test20091208.zip

を保存して使ってみてください。

返信2009/12/09 06:21:16

31ken3memoken3memo   28  3.印刷FLGの全てにチェックを入れる/チェックを外す

3.印刷FLGの全てにチェックを入れる/チェックを外す

印刷フラグをチェックして、

□チェックボックスにチェックの入ったデータを印刷しました。

よくある操作の質問がきました。

>もし方法がありましたら教えてほしいのです。

>

>印刷FLGにチャックを入れて、一括はずす方法ってありますか?

ですよねぇ、

一括で外す(クリア)、一括で付ける(全て)の動作が必要ですよね。

返信2009/12/09 06:24:35

32ken3memoken3memo   31  3.1 単純にクエリーを作りボタンで実行した

3.1 単純にクエリーを作りボタンで実行した

簡単なのは、更新クエリーで 印刷フラグをON,OFFする方法かなぁ。

それをボタンが押されたら呼ぶとか?

・Q印刷FLGを全てOFF

・Q印刷FLGを全てON

の2つの似たようなクエリーを作ります。

f:id:ken3memo:20091209055801j:image

あとは作成したクエリーを、ボタンが押されたら実行させて終了です。

Private Sub PrintOFF_Click()
On Error GoTo Err_PrintOFF_Click

    Dim stDocName As String

    Me.Refresh  '最後のチェックが残ってしまうので、データをまず確定させる
    
    DoCmd.SetWarnings False  'クエリーの↓警告を出したくないので警告メッセージをOFF

    stDocName = "Q印刷FLGを全てOFF"  'クエリーの名前
    DoCmd.OpenQuery stDocName, acNormal, acEdit  'クエリーを実行する
    
    Me.Requery  'FLGが↑更新されたので、再描画を兼ねて.Requeryでキレイにする。

Exit_PrintOFF_Click:
    Exit Sub

Err_PrintOFF_Click:
    MsgBox Err.Description
    Resume Exit_PrintOFF_Click
    
End Sub

Private Sub PrintON_Click()  '↑上のOFFからコピーして作成、クエリー名だけ変えた。

    Dim stDocName As String

    Me.Refresh  '最後のチェックが残ってしまうので、データをまず確定させる
    
    DoCmd.SetWarnings False  'クエリーの↓警告を出したくないので警告メッセージをOFF

    stDocName = "Q印刷FLGを全てON"  'クエリーの名前
    DoCmd.OpenQuery stDocName, acNormal, acEdit  'クエリーを実行する
    
    Me.Requery  'FLGが↑更新されたので、再描画を兼ねて.Requeryでキレイにする。

End Sub

↑なんて、軽く書いてますが、

クエリー実行時にメッセージが出て消す方法をど忘れして、

ヘルプを探せなくて googleで検索したり、( DoCmd.SetWarnings False を探した)

チェックボックスが全てON/OFFできなくて、( Me.Refresh で 最後のデータを確定)

そして、最後に、クエリー実行後、画面が変化無かったので(笑)

( Me.Requery で 再描画を兼ねて.Requeryでキレイにする)

と、いった、恥ずかしい作業内容は下記の手順動画をみて笑ってください。

[動画を貼る]

http://www.youtube.com/watch?v=RX_pILml11c

↑プログラムの作成過程は見せるモンじゃないと思いつつ・・・・


今回の問い合わせ2009-12-08の分は

http://ken3hitori.g.hatena.ne.jp/bbs/2/28?mode=tree

のツリーを見てください。

全体の開発の流れを見るには

http://ken3hitori.g.hatena.ne.jp/bbs/2?mode=tree

のツリーを見てください。

サンプルファイルは

http://d.hatena.ne.jp/ken3memo/files/Test20091208.zip

を保存して使ってみてください。

返信2009/12/09 06:25:52

33ken3memoken3memo   31  3.2 チェックボックスの値が変わったら、FLG更新のSQLを実行する

3.2 チェックボックスの値が変わったら、FLG更新のSQLを実行する

チェックボックスの値が変わったら、FLG更新のSQLを実行する

もう一つの方法として、

□ALL印刷FLG

とチェックボックスを1つ作成して、ヘッダーに配置します。

チェックボックスの値が変化したら(外す・付ける)、

更新のSQLを走らせる、そんな処理を作ってみたいと思います。

ア.タイミングと値の確認

まずは、タイミングを知りたいので、

フォームにチェックボックスを配置したら、

更新後の処理でテストしてみます。

f:id:ken3memo:20091209055800j:image

Private Sub ALL印刷FLG_AfterUpdate()
    If Me.ALL印刷FLG Then
        MsgBox "on"
    Else
        MsgBox "off"
    End If
End Sub

イ.SQL文の確認 SQLピューで確認する

実行したいSQL文を確認するには(直接書ける人は必要ないのですが)

一番簡単なのが、クエリーで作成後にSQLピューを見る方法です。

f:id:ken3memo:20091209055759j:image

SQLピュー↑で簡単に確認することができます

UPDATE 社員テーブル SET 社員テーブル.印刷FLG = Yes;

ウ.SQLの実行コマンドを調べる

次に、SQLの実行コマンドを調べたいので、

マクロでSQLの実行を1つ作り、

作成後に 名前を付けて保存 モジュール を選択してコードを作成します。

f:id:ken3memo:20091209055758j:image

すると、下記のようなモジュールが作成されます。


'------------------------------------------------------------
' マクロ1
'
'------------------------------------------------------------
Function マクロ1()
On Error GoTo マクロ1_Err

    DoCmd.RunSQL "UPDATE 社員テーブル ", -1


マクロ1_Exit:
    Exit Function

マクロ1_Err:
    MsgBox Error$
    Resume マクロ1_Exit

End Function

ここから、DoCmd.RunSQL "SQL文"が SQLを実行するVBAと知ることができます。

エ.チェックボックスのON/OffでSQL文を実行させる

やっとパーツがそろったので、チェックボックスの値が変化したら、

テーブルの印刷フラグを全て更新するSQL文を走らせたいと思います。

いきなり完成した形を書くとこんな感じです。

Private Sub ALL印刷FLG_AfterUpdate()
    
    Me.Refresh   '編集中のFLGを強制的に更新する
    DoCmd.SetWarnings False  '警告メッセージをOFFにする
    If Me.ALL印刷FLG Then    'フラグの状態によって発行するSQLを変化させる
        DoCmd.RunSQL "UPDATE 社員テーブル SET 社員テーブル.印刷FLG = Yes;", -1
    Else
        DoCmd.RunSQL "UPDATE 社員テーブル SET 社員テーブル.印刷FLG = No;", -1
    End If
    Me.Requery  '再描画を兼ねて、再クエリーでフォームデータをキレイにする

End Sub

↑さらっと、書いてるけど、いつものようにハマってます。

↓こんな感じでハマりながら、たどりつきました。

[試行錯誤の動画]を入れる。

http://www.youtube.com/watch?v=X2rUiWnLB6A

Me.Refresh が無かったら

Me.Refresh の強制更新が無かったら、

データの競合

このレコードは他のユーザーによって変更されています。[レコードの保存] を選択すると他のユーザーによる変更を無視し、自分が行った変更を反映します。

f:id:ken3memo:20091209055757j:image

と、メッセージが表示されます。その後、

実行時エラー3197:

他のユーザーが同じデータに対して同時に変更を試みているので、プロセスが停止しました。

f:id:ken3memo:20091209055756j:image

なんて感じになったりします。

Me.Refreshで更新してから、SQLが走ればメッセージがでません(正常に処理できます)

DoCmd.SetWarnings False が無かったら

DoCmd.SetWarnings False の警告無視が無かったら

レコードが更新されます。と親切なメッセージが表示されます。

f:id:ken3memo:20091209055755j:image

Me.Requery が無かったら

Me.Requery が無かったら、

データが更新されているのに、

画面がそのままだったりして・・・・


たった数行のプログラムを書くのに三流プログラマーらしくハマってしまった(笑)

今回の問い合わせ2009-12-08の分は

http://ken3hitori.g.hatena.ne.jp/bbs/2/28?mode=tree

のツリーを見てください。

全体の開発の流れを見るには

http://ken3hitori.g.hatena.ne.jp/bbs/2?mode=tree

のツリーを見てください。

サンプルファイルは

http://d.hatena.ne.jp/ken3memo/files/Test20091208.zip

を保存して使ってみてください。

返信2009/12/09 06:31:48

34ken3memoken3memo   12/21 Accessから単票をExcelへ出力(はめ込み)

要求を聞き、概要と処理イメージを作成する

1.要求仕様

>バック一覧からいろいろ探して、やってみましたが、1日やっても結果がでませんでした。

>エクセルで資格名がもうはいってまして、それにあった取得日と資格証NOを返したのですが、

>どうしたらよろしいでしょうか?

>この中の資格はすべて持ってるわけではないので、ないところは空欄で返したいです。

>

>違うエクセルフォームに名簿データと資格を埋め込んでいきたいです。

>今回は1ページに一人の情報入れたいです。

>

f:id:ken3memo:20091221133034j:image

丁寧な質問メッセージ↑と出力結果の画像が送られてきた

そんな依頼が舞い込んできたら・・・

またまた、三流プログラマー的に修正・追加を泥縄式に行ってみたいと思います。


作成したサンプルファイル

2009/12/21 : http://www.ken3.org/vba/zip/Test1221.zip

動かしながら、遊んでみてください。

返信2009/12/22 23:01:08

35ken3memoken3memo   34  2.変更点の概要を作成する Accessから単票をExcelへ出力(はめ込み)

2.変更点の概要を作成する

2.1 資格証NO項目の追加

資格取得日と資格証の番号を管理したいので、

新規項目 [資格証NO] を 資格取得テーブルに追加する。

ア.資格取得テーブルに資格証NOを追加する

f:id:ken3memo:20091221133031j:image

イ.入力フォームを修正する(資格証NOの入力)

取得日と資格証NOをペアで入力する。

f:id:ken3memo:20091221133149j:image

↑入れる箱(ア) と 入れる処理(イ)を作ります。

2.2 単票出力処理の作成

データが完成したので、次は、個人の資格を単票に出力します。

出力するには、まず、

ア.単票テンプレートの作成

  今回の出力先のひな型を テンプレート資格.xls で作成します。

f:id:ken3memo:20091221133148j:image

イ.出力データの選択処理

  出力したい個人を特定します。(印刷指示のフォームにボタンを追加します)

f:id:ken3memo:20091221133146j:image

ウ.出力処理

  選ばれた社員のデータを読み込み、テンプレート資格.xls に ハメ込みます。

f:id:ken3memo:20091221133145j:image

概要を日本語で簡単に書くとこんな感じ?です。

ここから、詳細が長いんだけど・・・

動画、今回はあまり意味無いけど

http://www.youtube.com/watch?v=36jcW4yfBto

返信2009/12/22 23:03:16

36ken3memoken3memo   34  3.プログラム修正 Accessから単票をExcelへ出力(はめ込み)

3.プログラム修正

詳細に落としていないので、いきなり修正始めるとハマるのですが、

まぁ、ハマったらハマったで面白いので、続けます。

3.1 資格証NO項目の追加

ア.資格取得テーブルに資格証NOを追加する

テーブルを修正する

f:id:ken3memo:20091222101944j:image

まぁ、普通にテキスト型で項目を追加します。

コレで取得した日付と番号を管理します。

イ.入力フォームを修正する(資格証NOの入力)

取得日と資格証NOをペアで入力する。

サブフォーム SF資格入力を修正する

f:id:ken3memo:20091222101943j:image

まぁ、これくらいは詳細設計無しでも、なんとか・・なるかなぁ。

返信2009/12/22 23:13:32

37ken3memoken3memo   36  3.2 単票出力処理の作成 Accessから単票をExcelへ出力(はめ込み)

3.2 単票出力処理の作成

データの保管、入力系が完成したので、

次は、個人の資格を単票に出力します。

作成手順は、順番が前後したりしますが、下記の3つかなぁ。

(修正しながら行ってみます)

ア.単票テンプレートの作成

  今回の出力先のひな型を テンプレート資格.xls で作成します。

ここの作戦ポイントは、セルに名前を付けることなんですが(あとからわかるのですが)

まぁ、説明はひとまず置いて、普通にフォーマットを作成します。

f:id:ken3memo:20091222101942j:image

イ.出力データの選択処理

  出力したい個人を特定したいので、(印刷指示のフォームにボタンを追加します)

b単票のボタンを詳細に追加します。

f:id:ken3memo:20091222101941j:image

  一覧フォームのカレントレコードの社員番号を利用して、出力関数を呼びます。

Private Sub b単票_Click()
    Call 資格印刷(Me.社員番号)
End Sub

ココまでの動作手順 : http://www.youtube.com/watch?v=_HUvcd-Jv5g

テスト用のファイルを: http://www.ken3.org/vba/zip/Test1221.zip に保存しました。

返信2009/12/22 23:15:32

38ken3memoken3memo   36  3.3 社員番号を受け取り 資格テンプレートにデータをセットする

3.3 社員番号を受け取り 資格テンプレートにデータをセットする

ウ.出力処理 の 第1段階で、該当データの抜き出しまで。

  選ばれた社員のデータを読み込み、テンプレート資格.xls に ハメ込みます。

社員番号を受け取り、資格取得テーブルからデータを読み込みます。

  ※Excelを開いてセットは、まだで、データを取り出し デバッグで表示する

3.3.1 社員番号を受け取り、資格名称と資格取得日、資格証NOの取り出し

Subの関数、資格印刷(社員番号 as string) と、社員番号を受け取る関数を作ります。

次に、セットしたい資格名称と取得年月日、資格証NOを取り出します。

Private Sub 資格印刷(社員番号 As String)

    Dim strSQL As String

    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"
    
    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            
            Debug.Print rs.Fields("資格名称") & " " & rs.Fields("取得年月日") & " " & rs.Fields("資格証NO")
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

End Sub
返信2009/12/22 23:21:43

39ken3memoken3memo   38  3.3.2 テンプレートファイルを開くマクロを追加します

3.3.2 テンプレートファイルを開くマクロを追加します

取り出しの確認ができたら、Excelファイルを開くマクロを組み込みます。

AccessのデータをExcelへ転記する http://ken3hitori.g.hatena.ne.jp/bbs/2/14 を参考にしてください。

組み込むと、こんな感じになります。

Private Sub 資格印刷(社員番号 As String)

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls

  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート資格.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート資格.xls").Activate
    oApp.Sheets("資格").Select
    oApp.Sheets("資格").Copy
    oApp.Windows("テンプレート資格.xls").Activate
    oApp.ActiveWorkbook.Close

    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"
    
    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            
            Debug.Print rs.Fields("資格名称") & " " & rs.Fields("取得年月日") & " " & rs.Fields("資格証NO")
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

End Sub

ここまでの操作動画: http://www.youtube.com/watch?v=Is7cBRHoQKM ※後半、実の親父と休みの件で会話してます。編集忘れましたミス(笑)

↑2:55 ぐらいから、Ken3の父親登場(笑)

テスト用のファイルを: http://www.ken3.org/vba/zip/Test1221.zip に保存しました。

話の流れを初めから見るにはツリー http://ken3hitori.g.hatena.ne.jp/bbs/2/34 を見てください。

返信2009/12/22 23:23:04

40ken3memoken3memo   38  3.3.3 データをマッチングさせセットします。

3.3.3 データをマッチングさせセットします。

マッチング処理は意外と大変なので、

手抜きで、テンプレートの Excelセルに名前を登録しておきます。

Excel2003 挿入 -- 名前 -- 定義

Excel2007 数式 -- 名前の定義

で、事前にテンプレートに名前を仕込んでおきます。。。

名前の定義は

http://d.hatena.ne.jp/ken3memo/20091221/1261356822

を見てください。

登録する名前は、マスターの名前を使用します。

(※Excelに表示されている正式名称じゃなくてマスターの名前)

Range("名前")を使用して、

セットする位置を決めて、

.Offset(0, 1) 隣(+1)に取得年月日

.Offset(0, 2) (+2)に資格証NO

をセットします

エクセルで定義した(設定した) 名前の隣に こんな感じ

oApp.range(rs.Fields("資格名称")).Offset(0, 1) = rs.Fields("取得年月日")

oApp.range(rs.Fields("資格名称")).Offset(0, 2) = rs.Fields("資格証NO")

で、.Offsetを使いセットしてみました。

Private Sub 資格印刷(社員番号 As String)

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls


  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート資格.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    'On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート資格.xls").Activate
    oApp.Sheets("資格").Select
    oApp.Sheets("資格").Copy
    oApp.Windows("テンプレート資格.xls").Activate
    oApp.ActiveWorkbook.Close


    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"
    
    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            
            Debug.Print rs.Fields("資格名称") & " " & rs.Fields("取得年月日") & " " & rs.Fields("資格証NO")
            oApp.range(rs.Fields("資格名称")).Offset(0, 1) = rs.Fields("取得年月日")
            oApp.range(rs.Fields("資格名称")).Offset(0, 2) = rs.Fields("資格証NO")
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

End Sub

動作と説明・解説 : http://www.youtube.com/watch?v=Q0PN0zYQYsU

↑なんか変だけど、こんな感じでセットできました。

テスト用のファイルを: http://www.ken3.org/vba/zip/Test1221.zip に保存しました。

話の流れを初めから見るにはツリー http://ken3hitori.g.hatena.ne.jp/bbs/2/34 を見てください。

返信2009/12/22 23:29:07

41ken3memoken3memo   38  3.3.4 エラー処理を入れる マスターの設定方法を少し説明

3.3.4 エラー処理を入れる マスターの設定方法を少し説明

oApp.range(rs.Fields("資格名称")).Offset(0, 1) = rs.Fields("取得年月日")

でデータをセットしているので、

資格名称がテンプレートに見つからない時の処理を入れます。

と言っても、最終的に手抜きで

On Error Resume Next

でエラーを無視しただけです(ぉぃぉぃ)

Private Sub 資格印刷(社員番号 As String)

    Dim oApp As Object     'Excelアプリの参照用
    Dim strWORK As String  '文字編集用のワーク変数
    Dim i As Integer
    Dim strMDBPATH As String   'MDBの保存場所、フォルダー・ディレクトリ
    Dim strXLSFILE As String   'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls


  'Excelファイルを開く
    'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている
    strWORK = CurrentDb.Name
    
    '後ろから1文字単位で¥を探す
    For i = Len(strWORK) To 1 Step -1
        If Mid(strWORK, i, 1) = "\" Then Exit For  '¥だったら抜ける
    Next i
    
    'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする
    strMDBPATH = Mid(strWORK, 1, i)

    'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls
    strXLSFILE = strMDBPATH & "テンプレート資格.xls"
    
    'ファイルの存在をチェックする
    If Dir(strXLSFILE) = "" Then
        MsgBox strXLSFILE & " の存在を 確認して下さい"
        Exit Sub  'エラーなので途中で抜ける
    End If

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    'On Error Resume Next
    oApp.UserControl = True

    'テンプレートファイルを開く
    oApp.Workbooks.Open Filename:=strXLSFILE
    
    'テンプレートファイルをcopy 2009-11-28 追加
    oApp.Windows("テンプレート資格.xls").Activate
    oApp.Sheets("資格").Select
    oApp.Sheets("資格").Copy
    oApp.Windows("テンプレート資格.xls").Activate
    oApp.ActiveWorkbook.Close


    Dim strSQL As String
    
    strSQL = "select * from Q資格"
    strSQL = strSQL & " where 社員番号='" & 社員番号 & "'"
    
    Dim strRET As String
    Dim rs As New ADODB.Recordset
    rs.Open strSQL, CurrentProject.Connection, _
                                adOpenKeyset, adLockOptimistic
    'ループ処理
    strRET = ""  'リターン値の初期化
    
    If rs.RecordCount > 0 Then '資格が1つでもあったら(0件以上)
        While rs.EOF = False  'いつものEOFが偽の間
            
            Debug.Print rs.Fields("資格名称") & " " & rs.Fields("取得年月日") & " " & rs.Fields("資格証NO")
            On Error Resume Next  'エラーを無視
            oApp.range(rs.Fields("資格名称")).Offset(0, 1) = rs.Fields("取得年月日")
            oApp.range(rs.Fields("資格名称")).Offset(0, 2) = rs.Fields("資格証NO")
            rs.MoveNext  '次のレコードに移動しないと、とんでもないことに(笑)
        Wend
    End If

    rs.Close   '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
    Set rs = Nothing  '変数も後始末しますか。使った器はキレイにしろって?

End Sub

詳細はドタバタ動画 : http://www.youtube.com/watch?v=t44aB8bgbl0 を見てください。

テスト用のファイルを: http://www.ken3.org/vba/zip/Test1221.zip に保存しました。

話の流れを初めから見るにはツリー http://ken3hitori.g.hatena.ne.jp/bbs/2/34 を見てください。

返信2009/12/22 23:34:16









    三流君 www.ken3.org(手打ちのHTMLで情報発信、最近は更新してなかったり...) 分類:HPを大きく分けると4つの柱(分類)です。
    ・人気は[VBA,マクロ]の解説、VBAからIE操作が人気です
    ・一昔前の[ASP(Active Server Pages)]の解説。
    ・読み物として[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
    ・おまけで[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の異業種へ転職、コンビニ店長で失敗。

    動画・YouTube(動画で解説に手を出してみたが、評判はイマイチ...内容に問題アリ?)
    ・YouTube [ken3video] え~と、こんな感じ...の独り言が多い解説やテストの動画です。

    流行のBlogで情報発信(手打ちのHTMLよりブログで更新が楽なので)
    ・はてなを使用して[id:ken3memo]メモ的に放り込んでいるブログです
    ・[その他商品紹介Blog] ・・・ 内容の薄い、商品のメモ?です



    トップ ユーザー登録 ログイン ヘルプ