データの取り込みと集計　（手作業での操作例と、それをVBAで。）

■ Excel豆知識53

53-6 そのまま取り込めるデータを毎月1回取り込み作業を行う（VBA）（53-4の続き）

前に、「②の何らかの抽出を行って取り込むデータ」を「Aの毎月1回取り込み作業を行う」場合のVBAの手順を書き
ましたが今作業をしているのは「①のそのまま取り込めるデータ」を「Aの毎月1回取り込み作業を行う」場合です。
抽出作業が不要な分、若干簡単です。
1.  取込が初回かどうかを判断する。      
2.　インプットボックスで、対象年月西暦を6桁の数字で入力してもらう。
3.　2の数字を利用してCSVファイル名を変数に取得。
4.  そのファイルの存在を確認。
       存在しない場合にはメッセージを出してマクロを終了。
5.  そのファイルのデータが既に取り込まれていないかどうかを確認。
　 　　取り込み済なら、メッセージを出してマクロを終了。
6. 「取込ファイル名」シートにファイル名を書き込む。
7.　該当するCSVファイルを開く。
8.  データを貯め込んでいる「Data」シートにデータを追加し、データ範囲に名前を設定。
9.　CSVファイルを閉じる。
10. 1で初回と判断した場合には、ピボットテーブルを作成してねとメッセージを表示。
　  　 初回でなければ、ピボットテーブルを更新。
11. 上書き保存
12. ピボットシートを選択してマクロを終了。


53-4で下記のコードまで作りました。

Option Explicit

Sub 取込test()
    Dim LastRow As Long

    With ThisWorkbook.Worksheets("Data")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Workbooks("Sample2.csv").Worksheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
                Destination:=.Cells(LastRow + 1, 1)
    End With
End Sub

このコードで出来たことは「8.データを貯め込んでいる「Data」シートにデータを追加し」の部分
です。


では、次に、「2.インプットボックスで、対象年月西暦を6桁の数字で入力してもらう。」の部分を
考えてみることにします。

変数のつけ方がローマ字でいい加減ですが、yyyymmの6桁数字なので、Dim Nengetu As Long　として
長整数型で宣言しました。

インプットボックスでその数字を入力してもらおうと思いますが、インプットボックスにはInputBoxメ
ソッドとInputBox関数があります。（InputBoxについてはこちら。）
今回は、数値しか入れられないようにしたいので、InputBoxメソッドの方を使おうと思います。赤字の
Type:=1の部分で数値を指定しています。

Sub test1()
    Dim Nengetu As Long

    Nengetu = Application.InputBox _
        (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", Title:="対象年月は？", Type:=1)

    If Nengetu = 0 Then
        Exit Sub
    Else
        MsgBox Nengetu & "のデータですね。"
    End If
End Sub

test1を実行すると、下図のインプットボックスが出ます。ここでこのまま「OK」としてみると、

下図のようなエラーメッセージが出ます。Type:=1で数値を指定しているために「空欄」は認められません。
「OK」で戻って、

201405とでも入力して「OK」とすると、

If Nengetu = 0の条件を満たしませんので、Else以下に移り、MsgBox Nengetu & "のデータですね。"　
のコードが実行されますので、変数Nengetuに取得した201405を入れ込んだメッセージが表示されます。
（数字ならばOKですので、ここでは2605とかでもいけてしまいます。ファイル名のyyyymmには該当しませんので、それは
後ほど考慮します。）

次に、「3. 2の数字を利用してCSVファイル名を変数に取得。」の部分を考えてみます。

ファイル名は文字列ですので Dim FName As String と文字列型で宣言します。
取込ファイル名の設定をこちらのようにしていますので、フルパスを含むファイル名は上で取得した変数
Nengetuを利用してThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV"と表すことが出
来ます。

Sub test2()
    Dim Nengetu As Long
    Dim FName As String

    Nengetu = Application.InputBox _
        (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", Title:="対象年月は？", Type:=1)

    If Nengetu = 0 Then
        Exit Sub
    Else
        FName = ThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV"
        MsgBox FName & "のデータを取り込みます。"
    End If
End Sub

test2を実行して出てくるインプットボックスに　201405 と入力して「OK」とすると、下図のように取り
込みたいファイルのフルパスとファイル名がメッセージボックスに表示されます。

次に「4.そのファイルの存在を確認。存在しない場合にはメッセージを出してマクロを終了。」の部分
を考えてみます。いろいろやり方はあると思いますが、ここではDir関数を使います。(Dirについてはこちら。)
下のtest3をステップ実行して、出てくるインプットボックスに2605と入力して「OK」としてみましょう。

Sub test3()
    Dim Nengetu As Long
    Dim FName As String

    Nengetu = Application.InputBox _
        (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", Title:="対象年月は？", Type:=1)

    If Nengetu = 0 Then
        Exit Sub
    End If

    FName = Dir(ThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV")

    If FName = "" Then
        MsgBox "取り込みファイルの準備がまだのようです。" & vbCrLf & "確認してください。"
        Exit Sub
    Else
        MsgBox FName & "のデータを取り込みます。"
    End If
End Sub

Excelのヘルプに「Dir関数は、引数 pathname と一致する最初のファイル名を返します。一致するファイル
名がない場合は、Dir 関数は長さ 0 の文字列を返します。」とあります。

変数Nengetuには2605が入りますが、ThisWorkbook.Path & "\CSV保存用\2605Data.CSV"と一致するファイ
ルが存在しませんので、変数FNameにカーソルをあてると FName = "" と、長さゼロの文字列になっている
のがわかります。（下の図は合成です。）

If FName = "" Then の条件を満たしますので、下図のメッセージが表示されて、Subを終了します。
なお、& vbCrLf &　でメッセージを改行して繋いでいます。

test3をステップ実行して、出てくるインプットボックスに201405と入力して「OK」とすれば、ファイルが
存在しますので、変数FNameにカーソルをあてると FName = "201405Data.CSV" と、ファイル名が取得され
ているのがわかります。そして、Dir関数で取得されるのはパス名を除いた「ファイル名」だけということ
もわかります。

If FName = "" Then の条件を満たしませんので、実行はElse以下へ移り、下図のメッセージが表示されます。

次は「5.そのファイルのデータが既に取り込まれていないかどうかを確認。取り込み済なら、メッセ
ージを出してマクロを終了。6.「取込ファイル名」シートにファイル名を書き込む。」の部分を考えて
みます。

上のtest3でファイルが存在した場合に、重複して取り込んだりすることがないように、確認をしたいと
思います。それをするために、取込用のマクロブックには「取込ファイル名」シートを用意しておいて
そこに取り込んだファイル名を書き込みます。次に取り込むときには、そこに同じファイル名があるか
どうかを確認します。

なお、test3では一致するファイルがあったらElse以下に実行が移るようにしましたが、ここからは「一
致するファイルが無かったらSubを抜ける」の後をすぐにEnd Ifとして、ファイルがあったらその先へ進
むようにしました。

「取込ファイル名」シートのデータの最終行を求める変数LRとFor〜Nextの繰り返しに用いる変数iをそれ
ぞれ長整数型で宣言します。（Dim LR As Long, i As Long と１行で複数の変数を宣言する時は、それぞれAsで型を
指定する必要があります。例えばここでDim LR, i As Long とすると、最初のLRはバリアント型で宣言したことになって
しまいます。）

Sub test4()
    Dim Nengetu As Long
    Dim FName As String
    Dim LR As Long, i As Long

    Nengetu = Application.InputBox _
        (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", Title:="対象年月は？", Type:=1)

    If Nengetu = 0 Then
        Exit Sub
    End If

    FName = Dir(ThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV")

    If FName = "" Then
        MsgBox "取り込みファイルの準備がまだのようです。" & vbCrLf & "確認してください。"
        Exit Sub
    End If

    With Worksheets("取込ファイル名")
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To LR
            If .Cells(i, 1).Value = FName Then
                MsgBox "そのファイルは取り込み済です。"
                Exit Sub
            End If
        Next i
        .Cells(LR + 1, 1).Value = FName
    End With
    MsgBox FName & "のデータを取り込みます。"

End Sub

test4をステップ実行して、出てくるインプットボックスに201405と入力して「OK」とし、ステップ実行
を下図の所まで続けると、「取込ファイル名」シートのA列の最終行を求めている変数LRに1が入ります。

For i = 2 To LRは、LRが2より小さいのでこの場合は実行されません。（「For i = 2 To LR Step -1」とかなら
実行されますが。）なので、ステップ実行で上図の次が下図です。

次に上の行が実行されると、Withで括られているので、
Worksheets("取込ファイル名").Cells(LR + 1, 1).Value = FName ということになり、
「取込ファイル名」シートのLR+1 で最終行の１行下のA列のセル、つまりA2セルに、
変数FNameに取得しているファイル名が代入され、下図の左のように 201405Data.csvと書き込まれ、

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

その後もう一度test4を実行し、インプットボックスで同じ201405を入力すると、LRは2になるのでIf以下
が実行され、

ファイル名が同じなので、If .Cells(i, 1).Value = FName の条件が満たされ、下図の行に実行が移り、

下図のメッセージが表示され、

Exit Sub でSubを抜け終了します。なので、その下の行へは実行が進みません。

まだ取り込まれていないファイル名の場合だけ、ファイル名を書き込み、その先の取り込みへ作業が進む
ことになります。

次は「7.該当するCSVファイルを開く。」の部分と「9.CSVファイルを閉じる。」の部分を、以前作って
おいた「8.データを貯め込んでいる「Data」シートにデータを追加し」のコードに付け加えます。

今回扱っているCSVデータは、こちらで、Excelブックとして開いて大丈夫なことを確認していますので
その開いたブック用の変数DataBkを Dim DataBk As Workbook とオブジェクト型で宣言します。
また、取込先の「Data」シートのデータの最終行用の変数LastRowを長整数型で宣言します。

Sub test5()
    Dim Nengetu As Long
    Dim FName As String
    Dim LR As Long, i As Long
    Dim DataBk As Workbook
    Dim LastRow As Long

    Nengetu = Application.InputBox _
        (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", _
							Title:="対象年月は？", Type:=1)

    If Nengetu = 0 Then
        Exit Sub
    End If

    FName = Dir(ThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV")

    If FName = "" Then
        MsgBox "取り込みファイルの準備がまだのようです。" & vbCrLf & "確認してください。"
        Exit Sub
    End If

    With Worksheets("取込ファイル名")
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To LR
            If .Cells(i, 1).Value = FName Then
                MsgBox "そのファイルは取り込み済です。"
                Exit Sub
            End If
        Next i
        .Cells(LR + 1, 1).Value = FName
    End With

    Workbooks.Open Filename:=ThisWorkbook.Path & "\CSV保存用\" & FName
    Set DataBk = ActiveWorkbook

    With ThisWorkbook.Worksheets("Data")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        DataBk.Worksheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
						Destination:=.Cells(LastRow + 1, 1)
    End With

    DataBk.Close SaveChanges:=False

    MsgBox Nengetu & "のデータを取り込みました。"

End Sub

最初に下の部分について見てみます。Dir関数で変数FNameに取得出来たのは、パス名を含まないファイル
名でしたので、Workbooks.Openの引数にFilename:=ThisWorkbook.Path & "\CSV保存用\" & FName という
ふうにパス名をつけました。（Workbooks.Openについてはこちら。）

そして、開いたブックは必ずアクティブになりますので、Set DataBk = ActiveWorkbookとして変数DataBk
にそれを代入します。

    Workbooks.Open Filename:=ThisWorkbook.Path & "\CSV保存用\" & FName
    Set DataBk = ActiveWorkbook

開いたブックがアクティブになるのを一応確認してみます。下図は取込用のマクロブックをアクティブ
にしてtest6を実行し、インプットボックスで201405と入れて黄色の部分まで来たところです。これから
黄色の行が実行されます。

下図のように、開いたブックがアクティブになりました。

そして、前に作っていた下記のコードの直接ファイル名を入れていた赤字の部分の代わりに変数DataBkを
利用します。

Sub 取込test()
    Dim LastRow As Long

    With ThisWorkbook.Worksheets("Data")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Workbooks("Sample2.csv").Worksheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
                Destination:=.Cells(LastRow + 1, 1)
    End With
End Sub

ということで、データをコピペし終わった状態が下図です。

そして、データの取り込みが終わったら、ブックを閉じます。（Workbooks.Closeについてはこちら。）

    DataBk.Close SaveChanges:=False

下図のようにCSVのブックは閉じられ、

メッセージが表示されます。

次は、ピボットテーブルのデータソースに関連する部分について考えてみます。

53-2で手作業で取込をしてピボットテーブルを作成した時には、データソースに「テーブル」を利用しま
したが、今回はVBAの中でデータ範囲に「集計用データ」という名前をつけようと思います。その名前範
囲をデータソースにして、初回の取り込みの後に手作業でピボットテーブルを作成し、あとは毎回の取込
のVBAの中で「ピボットテーブルの更新」をしようと思います。

ということで、「8.」のうちの「データ範囲に名前を設定。」「10.」のうちの「ピボットテーブルを
更新。」の部分を追加します。
また、画面のちらつきを抑えるように、Application.ScreenUpdating = False を入れました。

Sub test6()
    Dim Nengetu As Long
    Dim FName As String
    Dim LR As Long, i As Long
    Dim DataBk As Workbook
    Dim LastRow As Long

    Nengetu = Application.InputBox _
        (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", Title:="対象年月は？", Type:=1)

    If Nengetu = 0 Then
        Exit Sub
    End If

    FName = Dir(ThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV")

    If FName = "" Then
        MsgBox "取り込みファイルの準備がまだのようです。" & vbCrLf & "確認してください。"
        Exit Sub
    End If

    With Worksheets("取込ファイル名")
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To LR
            If .Cells(i, 1).Value = FName Then
                MsgBox "そのファイルは取り込み済です。"
                Exit Sub
            End If
        Next i
        .Cells(LR + 1, 1).Value = FName
    End With

    Application.ScreenUpdating = False

    Workbooks.Open Filename:=ThisWorkbook.Path & "\CSV保存用\" & FName
    Set DataBk = ActiveWorkbook

    With ThisWorkbook.Worksheets("Data")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        DataBk.Worksheets(1).Range("A1").CurrentRegion.Offset(1).Copy Destination:=.Cells(LastRow + 1, 1)
        .Range("A1").CurrentRegion.Name = "集計用データ"
    End With

    DataBk.Close SaveChanges:=False

    Application.ScreenUpdating = True

    ThisWorkbook.RefreshAll

    MsgBox Nengetu & "のデータを取り込みました。"
End Sub

Withで括られているので、下のように表すことが出来て、「Data」シートのA1セルから繋がった範囲に
「集計用データ」という名前を付けます。

Worksheets("Data").Range("A1").CurrentRegion.Name = "集計用データ"

そして、下のコードでそのブックにあるピボットテーブルすべてを一度に更新することが出来ます。
（外部データとの接続があったりするとそれも更新されますので、何かあったらそれなりに工夫を。^^;）
（RefreshAllについてはこちら。）

ThisWorkbook.RefreshAll

残ったのは「1. 取込が初回かどうかを判断する。10.1で初回と判断した場合には、ピボットテーブル
を作成してねとメッセージを表示。11. 上書き保存。12. ピボットシートを選択してマクロを終了。」
という部分になりました。
これらを入れて、とりあえずの最終形になったのが下の「データ取込」のコードです。
（11と12の部分は今はとりあえずコメントアウトさせています。テスト中なので、上書き保存したくない
こともありますので、完成したらコメントじゃなくします。）

また、コード中に一応のコメントを書き込みました。

確認用の変数Kakuninを Dim Kakunin As Boolean とブール型で宣言しました。

Sub データ取込()
    Dim Nengetu As Long
    Dim FName As String
    Dim DataBk As Workbook
    Dim LastRow As Long
    Dim LR As Long, i As Long
    Dim Kakunin As Boolean

    '初回の取り込みで、ピボットを作る必要があるかどうかを確認
    If Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
        Kakunin = True
    End If

    '対象年月取得
    Nengetu = Application.InputBox _
            (prompt:="対象年月西暦を 6桁の数字で 201403 のように入力してください。", Title:="対象年月は？", Type:=1)
    If Nengetu = 0 Then
        Exit Sub
    End If

    'CSVファイル名を変数に取得
    FName = Dir(ThisWorkbook.Path & "\CSV保存用\" & Nengetu & "Data.CSV")

    'ファイルの存在を確認
    If FName = "" Then
        MsgBox "取り込みファイルの準備がまだのようです。" & vbCrLf & "確認してください。"
        Exit Sub
    End If

    '既に取りこんでいないかどうかを確認
    With Worksheets("取込ファイル名")
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To LR
            If .Cells(i, 1).Value = FName Then
                MsgBox "そのファイルは取り込み済です。"
                Exit Sub
            End If
        Next i
        'ここに来るのはまだ取りこんでない場合なので、ファイル名を入力
        .Cells(LR + 1, 1).Value = FName
    End With

    Application.ScreenUpdating = False

    'CSVファイルをExcelブックとして開く
    Workbooks.Open Filename:=ThisWorkbook.Path & "\CSV保存用\" & FName
    Set DataBk = ActiveWorkbook

    'データを取得
    With ThisWorkbook.Worksheets("Data")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        DataBk.Worksheets(1).Range("A1").CurrentRegion.Offset(1).Copy Destination:=.Cells(LastRow + 1, 1)
        'データ範囲に名前を付ける（ピボットのデータソース）
        .Range("A1").CurrentRegion.Name = "集計用データ"
    End With

    'CSVファイルを閉じる
    DataBk.Close SaveChanges:=False

    Application.ScreenUpdating = True

    If Kakunin = True Then
        '初回の取り込みならピボットテーブルを作成してねとメッセージを。（余裕があればVBAにしてもいいですが。）
        MsgBox Nengetu & "のデータを取り込みました。" & vbCrLf & "「集計用データ」をデータソースにして" _
        　　　　　　　　　　　　　　　　　　　　　　　　& vbCrLf & "ピボットテーブルを作成してください。"
    Else
        'ピボットを更新（初回以降ピボットテーブルが無くてもエラーにはなりません。）
        '複数のピボットテーブルがあっても、これで一度に更新できます。
        ThisWorkbook.RefreshAll
        '取り込んだよのメッセージを。
        MsgBox Nengetu & "のデータを取り込みました。"
    End If

'    '上書き保存
'    ThisWorkbook.Save
'
'    Worksheets("ピボット").Select
End Sub

これで「①のそのまま取り込めるデータ」を「Aの毎月1回取り込み作業を行う」場合のコードは出来まし
た。次回は、「②の何らかの抽出を行って取り込むデータ」を「Aの毎月1回取り込み作業を行う」場合に
ついて考えてみたいと思います。


余談ですが。
今作成しているマクロは、最終的には取込用のマクロブックのシートにボタンを置いて、それをクリックして作業
を開始しようと思っていますので、完成したあとでは起こることのないエラーのはずなのですが、私がこの豆知識
53を作りながら時々出しているエラーがあります。^^;

豆知識のページ作成のために画像を切ったり貼ったりしている作業用のブックを開きながらこれを書いているので
すが、うっかりそのブックをアクティブにしたままでテスト用のコードを実行してしまうことがあります。そうす
ると、下図のようなエラーが出ます。

ここでデバッグを押すと下図の行が黄色になっています。

アクティブになっている作業用のブックに「取込ファイル名」という名前のシートが存在しないために起きたエラー
です。
53-4で、ブックやシートの指定を省略した場合には、「アクティブになっているブックのアクティブになっているシ
ート」に対してということが省略されているという解釈になるということを書きましたが、上図ではWorksheets("取
込ファイル名")というふうにシートの指定はしていても、そのシートがどのブックのシートなのかの指定をしていま
せん。
なので、実際にマクロを実行する際に、こういうケースも有り得るという場合には、きちんと「どのブックの」とい
う指定をするように気を付ける必要があります。

更に余談ですが、仕事で使わざるを得ない銀行用のソフトがあるのですが、このような複数のブックを開いているこ
とに原因のあるエラーが出ないようにする配慮なのだと思うのですが「実行する際には他のExcelブックはすべて閉じ
てください。」という断り書きのあるソフトがあります。で、全部閉じて実行しようと思ったのですが、何と「個人
用マクロブック」が存在すると「他のエクセルブックを閉じてから再度○○を起動して下さい。」のメッセージが出
て、そのソフトを使うことが出来ないのです。そのソフトを作った人が「このソフトを使う人は"個人用マクロブック"
なんて使ってない」と思ったのか、個人用マクロブックの存在を全く意識しなかったためにそういう作りになってし
まったのか、不明ですが、配慮が足りないなあと思いました。（これは愚痴です。^^;）