【マクロ】元データを別ファイルへコピペ＆自動更新したい

Question

毎日更新される元データとなるデータファイルがあります。
それを、私のほうで集計する為に集計用のファイルを作っており、DBとして毎日データをコピペで蓄積しています。
これを自動反映できるようにしたいのですが、いい方法はありますでしょうか？

・元データは「実績0123」というようなタイトルで、毎日日付の部分は変更されてデータがきます。
項目列はA列からR列まであります。
集計用DBですが、蓄積しているので、更新したいのは今でいうと1月のデータです。
また、全部の列でははなく場合によっては特定の列のデータのみデータ蓄積・更新したい場合は
どのようにしたらよいか？ご教授頂ければ幸いです。

tatsu99 · Accepted Answer

多少早くなるようにしました。
データ1万件で確認したところ、こちらの環境では、
変更前：５秒
変更前：２秒
で、2～３倍程度速くなりました。前のマクロと入れ替えてください。
------------------------------------------------
Public Sub バックアップ処理2()
    Dim sh1 As Worksheet    'データシート
    Dim sh2 As Worksheet    'バックアップシート
    Dim sh As Worksheet     '管理シート
    Dim dataFolder As String    '元データフォルダ
    Dim dataFile As String      '元データファイル
    Dim dataSheet As String     '元データシート
    Dim myBook As String        'バックアップブック名
    Dim backSheet As String     'バックアップシート
    Dim fullpath As String      '元データシートのフルパス
    Dim maxRow1 As Long         'データシート最大行
    Dim row1 As Long            'データシート行
    Dim row2 As Long            'バックアップシート行
    Dim yyyy As Long            '年
    Dim mm As Long              '月
    Dim rg1 As String           'データシートレンジ
    Dim rg2 As String           'バックアップシートレンジ
    Dim t1 As Variant
    Dim t2 As Variant
    If MsgBox("バックアップを開始します", vbOKCancel) = vbCancel Then Exit Sub
    myBook = ThisWorkbook.Name
    Set sh = Worksheets("管理")
    dataFolder = sh.Cells(2, "A").Value
    dataFile = sh.Cells(2, "B").Value & ".xlsx"
    dataSheet = sh.Cells(2, "C").Value
    backSheet = sh.Cells(2, "D").Value
    If ExistsWorkSheet(backSheet) = False Then
        MsgBox (backSheet & "は存在しません")
        Exit Sub
    End If
    If Dir(dataFolder, vbDirectory) = "" Then
        MsgBox (dataFolder & "は存在しません。")
        Exit Sub
    End If
    fullpath = dataFolder & "\" & dataFile
    If Dir(fullpath) = "" Then
        MsgBox (fullpath & "は存在しません。")
        Exit Sub
    End If
    Workbooks.Open fullpath
    Workbooks(dataFile).Activate
    If ExistsWorkSheet(dataSheet) = False Then
        MsgBox (dataFile & "中に" & dataSheet & "は存在しません")
        Workbooks(dataFile).Close
        Exit Sub
    End If
    Set sh1 = Worksheets(dataSheet) '元データシート
    maxRow1 = sh1.Cells(Rows.count, 1).End(xlUp).row    '元データシートの最大行取得
    If maxRow1 < 2 Then
        MsgBox (dataSheet & "にデータなし")
        Workbooks(dataFile).Close
        Exit Sub
    End If
    yyyy = year(sh1.Cells(2, "G").Value)  'データの年を取得
    mm = month(sh1.Cells(2, "G").Value)  'データの月を取得
    'バックアップシートの書き込み開始位置を検索する
    Workbooks(myBook).Activate
    Set sh2 = Worksheets(backSheet) 'バックアップシート
    For row2 = 2 To Rows.count
        If sh2.Cells(row2, "L") = "" Then Exit For
        If year(sh2.Cells(row2, "L")) = yyyy And month(sh2.Cells(row2, "L")) = mm Then Exit For
    Next
    sh2.Activate
    sh2.Range("L" & row2).Activate
    If MsgBox(backSheet & "の" & row2 & "行以降へ書き込みます", vbOKCancel) = vbCancel Then
         Workbooks(dataFile).Close
       Exit Sub
    End If
    t1 = Time
    Application.ScreenUpdating = False
    'データをバックアップシートへコピーする
    For row1 = 2 To maxRow1
        rg1 = "A" & row1 & ":R" & row1
        rg2 = "F" & row2 & ":W" & row2
        Workbooks(myBook).Worksheets(backSheet).Range(rg2).Value = Workbooks(dataFile).Worksheets(dataSheet).Range(rg1).Value
        row2 = row2 + 1
    Next
    Workbooks(dataFile).Close
    Application.ScreenUpdating = True
    t2 = Time
    MsgBox ("バックアップ処理完了　処理件数=" & maxRow1 - 2 + 1 & " 処理時間=" & Minute(t2 - t1) & "分" & Second(t2 - t1) & "秒")
End Sub
-------------------------------------------------------
変更箇所は、copy命令をやめて代入命令に変えただけです。
（他に時間計測の命令を追加してます）
コピーではないので、集計先のL列の値が数値の可能性があります。その場合は、
L列の書式設定を適切に行い、日付が表示されるようにしてください。（書式のコピーはしません）

余談ですが、こちらでは、前回のマクロでも６秒で完了します。
多分、あなたのパソコンの処理能力が低いのとメモリ不足が原因の可能性が高いです。
このバックアップ実行時は、できるだけ他の処理を終了させ、このexcelだけが動くように
してください。そうすれば、もっと処理時間が短縮できると思われます。

tatsu99 · Answer

>この元データがかなり重く、作業完了するまでにかなり時間がかかってしまうのですが
>何か軽減するモジュールはありますでしょうか？

作業完了するまでの時間とは、このバックアップ処理2の作業が完了するまでの時間と理解しました。
幾つか質問がありますので補足ください。

質問１）1月末が最大になると思いますが、その時は、約何行（＝何件）ありますか。
質問２）現在、完了までにどのくらいの時間がかかっていますか。（例　約10分等）
また、この程度なら我慢できるという時間は、どの程度ですか。（例　約1分等）
質問3）バックアップ処理()でも、同様の現象が発生してますか。
質問の趣旨は、バックアップ処理２()だけでなく、バックアップ処理()も対策が必要かという意味です。

処理時間の問題は、元データのデータ量が多いことが、原因ですが、
①案
現行方式のまま、転送方法を改善する。（あまり、効果は期待できない）
つまり、1月1日以降のデータをまるまるコピーする方法です。
現行だと１月末に1か月分のデータをコピーすることになる。
②案
バックアップ方法を変える。
前日と当日の差分のみをバックアップする。

上記の対策が考えられますが、とりあえず①案でいきます。
1案で改善されない場合、②案になりますが、その場合は、更にヒアリングが必要になります。
（どのようにデータが増え、どのようにバックアップするか等を詳細に詰める必要があります）

tatsu99 · Answer

>もし、もう一度ご教授頂けるようでしたらG列が日付の場合のモジュールを再度ご教授頂ければ幸いです。
元データ　G列が日付
集計先　L列が日付　で作成しなおしました。
前回のバックアップ処理2()を全てこちらで置き換えてください。
-----------------------------------------------------
Public Sub バックアップ処理2()
    Dim sh1 As Worksheet    'データシート
    Dim sh2 As Worksheet    'バックアップシート
    Dim sh As Worksheet     '管理シート
    Dim dataFolder As String    '元データフォルダ
    Dim dataFile As String      '元データファイル
    Dim dataSheet As String     '元データシート
    Dim myBook As String        'バックアップブック名
    Dim backSheet As String     'バックアップシート
    Dim fullpath As String      '元データシートのフルパス
    Dim maxRow1 As Long         'データシート最大行
    Dim row1 As Long            'データシート行
    Dim row2 As Long            'バックアップシート行
    Dim yyyy As Long            '年
    Dim mm As Long              '月
    Dim rg1 As String           'データシートレンジ
    Dim rg2 As String           'バックアップシートレンジ
    If MsgBox("バックアップを開始します", vbOKCancel) = vbCancel Then Exit Sub
    myBook = ThisWorkbook.Name
    Set sh = Worksheets("管理")
    dataFolder = sh.Cells(2, "A").Value
    dataFile = sh.Cells(2, "B").Value & ".xlsx"
    dataSheet = sh.Cells(2, "C").Value
    backSheet = sh.Cells(2, "D").Value
    If ExistsWorkSheet(backSheet) = False Then
        MsgBox (backSheet & "は存在しません")
        Exit Sub
    End If
    If Dir(dataFolder, vbDirectory) = "" Then
        MsgBox (dataFolder & "は存在しません。")
        Exit Sub
    End If
    fullpath = dataFolder & "\" & dataFile
    If Dir(fullpath) = "" Then
        MsgBox (fullpath & "は存在しません。")
        Exit Sub
    End If
    Workbooks.Open fullpath
    Workbooks(dataFile).Activate
    If ExistsWorkSheet(dataSheet) = False Then
        MsgBox (dataFile & "中に" & dataSheet & "は存在しません")
        Workbooks(dataFile).Close
        Exit Sub
    End If
    Set sh1 = Worksheets(dataSheet) '元データシート
    maxRow1 = sh1.Cells(Rows.count, 1).End(xlUp).row    '元データシートの最大行取得
    If maxRow1 < 2 Then
        MsgBox (dataSheet & "にデータなし")
        Workbooks(dataFile).Close
        Exit Sub
    End If
    yyyy = year(sh1.Cells(2, "G").Value)  'データの年を取得
    mm = month(sh1.Cells(2, "G").Value)  'データの月を取得
    'バックアップシートの書き込み開始位置を検索する
    Workbooks(myBook).Activate
    Set sh2 = Worksheets(backSheet) 'バックアップシート
    For row2 = 2 To Rows.count
        If sh2.Cells(row2, "L") = "" Then Exit For
        If year(sh2.Cells(row2, "L")) = yyyy And month(sh2.Cells(row2, "L")) = mm Then Exit For
    Next
    sh2.Activate
    sh2.Range("L" & row2).Activate
    If MsgBox(backSheet & "の" & row2 & "行以降へ書き込みます", vbOKCancel) = vbCancel Then
         Workbooks(dataFile).Close
       Exit Sub
    End If
    Application.ScreenUpdating = False
    'データをバックアップシートへコピーする
    For row1 = 2 To maxRow1
        rg1 = "A" & row1 & ":R" & row1
        rg2 = "F" & row2
        Workbooks(dataFile).Worksheets(dataSheet).Range(rg1).Copy Workbooks(myBook).Worksheets(backSheet).Range(rg2)
        row2 = row2 + 1
    Next
    Workbooks(dataFile).Close
    Application.ScreenUpdating = True
    MsgBox ("バックアップ処理完了　処理件数=" & maxRow1 - 2 + 1)
End Sub
---------------------------------------

tatsu99 · Answer

No13の依頼ですが、訂正します。（No13は無視してください）以下の行を yyyy = year(sh1.Cells(2, "L").Value) 'データの年を取得・・・① ①の直前に追加して、実行してください。 MsgBox ("ファイル=" & fullpath & vbLf & "シート=" & dataSheet & vbLf & "L2.VALUE=<" & sh1.Cells(2, "L").Value & ">" & vbLf & "L2.TEXT=<" & sh1.Cells(2, "L").Text & ">") yyyy = year(sh1.Cells(2, "L").Value) 'データの年を取得・・・・① のようになります。ファイル名、シート名、L2の値（2017/1/1）、L2の表示上の値（1月１日）が表示されます。全て正しい値でしょうか。確認をお願いいたします。

tatsu99 · Answer

実行時エラー：１３
型が一致しません。
のエラーですが、L2の内容が日付でない（"abc"等）場合に発生します。

こちらで確認したかぎりでは、L2が不正としか考えられませんでした。
お手数ですが、以下の2行を
    yyyy = year(sh1.Cells(2, "L").Value)  'データの年を取得
の直前に追加して、その後、実行していただけませんでしょうか。（L2の内容を直接表示します）
    MsgBox (sh1.Cells(2, "L").Value)
    MsgBox (sh1.Cells(2, "L").Text)
    yyyy = year(sh1.Cells(2, "L").Value)  'データの年を取得
のようになります。
最初に 2017/1/1 が表示され
次に　1月1日　が表示されれば正しいセルになります。

tatsu99 · Answer

詳細情報ありがとうございました。

本当に念の為、確認ですが、参照しているブック、シート名が違っていたということはないですね。
「管理」シートの
B2：ブック名
C2：シート名
のL２のセルが1月1日になっていますか。

これから、ブック名、シート名のセルの内容に誤りがない前提で、確認作業に入ります。
もし、ブック名、シート名のセルの内容等で誤りに気付いた場合は、その旨、補足ください。

これから、エラーの再現及び原因調査を行います。
本日中の回答は難しいと思いますので、一旦打ち切ります。

tatsu99 · Answer

＞おっしゃる通り、2017/1/1で表示されておりますので
＞問題なしということですよね？
＞何度試してもやはりそこのエラーが出てしまいます。。。

すみません。日付が正しいとすると、私の想定外のエラーかもしれません。
エラーメッセージは、なんと表示されていますか？

文字でエラーメッセージを提示していただくか、画像で提示していただけませんでしょうか。

tatsu99 · Answer

③＞yyyy = Year(sh1.Cells(2, "L").Value) 'データの年を取得
→この部分にエラーがでます。
>>元データのL列が日付のはずですが、L2のセルが日付になっていません。L2のセルを見直してください。
→こちらについてですが、元データの日付が1月1日表記になっていることが原因でしょうか？

元データの日付が1月1日表記になっていることが原因でしょうか？
表記上1月1日なら問題ありません。
そのセル（L2）をクリックした時、fxが表示されている欄に 2017/1/1の日付が表示されれば問題ありません。（添付図の黄色部分参照）
もし、表示されなければ（"1月1日"の文字が格納されているなら）問題ありです。
もう一度、確認をお願いします。

tatsu99 · Answer

>原因は何が考えられますか？
以下回答です。
以下、エラーの発生する順に回答します。
エラー発生時は、一旦マクロを終了（リセット）し、オープン中のexcelファイルがあれば、
全て閉じてから、マクロを再度実行してください。（マクロのあるexcelは閉じなくて良いです）
①＞Workbooks.Open fullpath
→この部分にエラーがでます。
既にオープンされている可能性があります。
（手動でオープンかまたは前回マクロを途中で止めたままで終了するとオープンされた状態になります）
もし、上記いがいなら、アクセス権がないことが考えられますが、たぶんこのケースではないと思われます。

②＞Workbooks(dataFile).Activate
＞If ExistsWorkSheet(dataSheet) = False Then
＞MsgBox (dataFile & "中に" & dataSheet & "は存在しません")
①で正常終了していれば、ここではエラーにならないはずです。
①のあとで、強引に実行したと思われます。

③＞yyyy = Year(sh1.Cells(2, "L").Value) 'データの年を取得
→この部分にエラーがでます。
元データのL列が日付のはずですが、L2のセルが日付になっていません。L2のセルを見直してください。

tatsu99 · Answer

下記の要望の回答です。
>○元データファイル
>ファイル名、シート名ともに「実績0123」です。
>A列からR列まであります。
>日付はL列(見出しは納入日付)です。
>すべてのデータをコピペしたいです。
>○集計先
>A列からE列まで作業列がある為、F列からへデータを貼り付けたいです。

集計先はQ列が日付になります。
以下のモジュールを追加してください。（No7を基に作成してあります）
-------------------------------------------------------------
Public Sub バックアップ処理2()
    Dim sh1 As Worksheet    'データシート
    Dim sh2 As Worksheet    'バックアップシート
    Dim sh As Worksheet     '管理シート
    Dim dataFolder As String    '元データフォルダ
    Dim dataFile As String      '元データファイル
    Dim dataSheet As String     '元データシート
    Dim myBook As String        'バックアップブック名
    Dim backSheet As String     'バックアップシート
    Dim fullpath As String      '元データシートのフルパス
    Dim maxRow1 As Long         'データシート最大行
    Dim row1 As Long            'データシート行
    Dim row2 As Long            'バックアップシート行
    Dim yyyy As Long            '年
    Dim mm As Long              '月
    Dim rg1 As String           'データシートレンジ
    Dim rg2 As String           'バックアップシートレンジ
    If MsgBox("バックアップを開始します", vbOKCancel) = vbCancel Then Exit Sub
    myBook = ThisWorkbook.Name
    Set sh = Worksheets("管理")
    dataFolder = sh.Cells(2, "A").Value
    dataFile = sh.Cells(2, "B").Value & ".xlsx"
    dataSheet = sh.Cells(2, "C").Value
    backSheet = sh.Cells(2, "D").Value
    If ExistsWorkSheet(backSheet) = False Then
        MsgBox (backSheet & "は存在しません")
        Exit Sub
    End If
    If Dir(dataFolder, vbDirectory) = "" Then
        MsgBox (dataFolder & "は存在しません。")
        Exit Sub
    End If
    fullpath = dataFolder & "\" & dataFile
    If Dir(fullpath) = "" Then
        MsgBox (fullpath & "は存在しません。")
        Exit Sub
    End If
    Workbooks.Open fullpath
    Workbooks(dataFile).Activate
    If ExistsWorkSheet(dataSheet) = False Then
        MsgBox (dataFile & "中に" & dataSheet & "は存在しません")
        Workbooks(dataFile).Close
        Exit Sub
    End If
    Set sh1 = Worksheets(dataSheet) '元データシート
    maxRow1 = sh1.Cells(Rows.count, 1).End(xlUp).row    '元データシートの最大行取得
    If maxRow1 < 2 Then
        MsgBox (dataSheet & "にデータなし")
        Workbooks(dataFile).Close
        Exit Sub
    End If
    yyyy = year(sh1.Cells(2, "L").Value)  'データの年を取得
    mm = month(sh1.Cells(2, "L").Value)  'データの月を取得
    'バックアップシートの書き込み開始位置を検索する
    Workbooks(myBook).Activate
    Set sh2 = Worksheets(backSheet) 'バックアップシート
    For row2 = 2 To Rows.count
        If sh2.Cells(row2, "L") = "" Then Exit For
        If year(sh2.Cells(row2, "Q")) = yyyy And month(sh2.Cells(row2, "Q")) = mm Then Exit For
    Next
    sh2.Activate
    sh2.Range("Q" & row2).Activate
    If MsgBox(backSheet & "の" & row2 & "行以降へ書き込みます", vbOKCancel) = vbCancel Then
         Workbooks(dataFile).Close
       Exit Sub
    End If
    Application.ScreenUpdating = False
    'データをバックアップシートへコピーする
    For row1 = 2 To maxRow1
        rg1 = "A" & row1 & ":R" & row1
        rg2 = "F" & row2
        Workbooks(dataFile).Worksheets(dataSheet).Range(rg1).Copy Workbooks(myBook).Worksheets(backSheet).Range(rg2)
        row2 = row2 + 1
    Next
    Workbooks(dataFile).Close
    Application.ScreenUpdating = True
    MsgBox ("バックアップ処理完了　処理件数=" & maxRow1 - 2 + 1)
End Sub
------------------------------------
もし、このマクロをNo７のマクロと異なるブックに格納する場合は、
NO7の下記プロシージャもコピーして一緒に格納してください。
'ワークシートの存在チェック
Public Function ExistsWorkSheet(ByVal sheetName As String) As Boolean

不明点、不備がありましたら補足ください。

【マクロ】元データを別ファイルへコピペ＆自動更新したい

多少早くなるようにしました。

>この元データがかなり重く、作業完了するまでにかなり時間がかかってしまうのですが

>もし、もう一度ご教授頂けるようでしたらG列が日付の場合のモジュールを再度ご教授頂ければ幸いです。

No13の依頼ですが、訂正します。

実行時エラー：１３

詳細情報ありがとうございました。

＞おっしゃる通り、2017/1/1で表示されておりますので

③＞yyyy = Year(sh1.Cells(2, "L").Value) 'データの年を取得

>原因は何が考えられますか？

下記の要望の回答です。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング