【コード】(待望の)自動転記第2弾～喜んでもらえたVBA～

コード載せてますので、みなさんアレンジしてみてくださいみてください！変数のつけ方変ですみません(泣)独学なので、、、

■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

Sub DataInput()

Dim strPath As String '本ファイルのパス(フォルダ)

Dim wsMe As Worksheet '本ファイル 転記先のシート

Dim strFile As String '転記元のフォームのファイル名

Dim wsOri As Worksheet '転記元のシート　original worksheetの略のつもり、、、

Dim i As Long '転記先の行数を取得

Dim meLastRow As Long, oriLastRow As Long '本ファイル、転記元の最終行

Dim oriCol As Long '転記元の最終列

Dim oriFolder As String '本データ保存フォルダ名

Dim numDate As Long

Application.ScreenUpdating = False '画面表示更新をストップする

Application.Calculation = xlCalculationManual '計算を手動に

numDate = ThisWorkbook.Worksheets("集計").Cells(2, 1) + 1 '最新日付+1

'ここには元データの日付列のMAXを求める関数入っています！

Set wsMe = ThisWorkbook.Worksheets("データ")’★

strPath = ThisWorkbook.Path '本ファイルのパス(フォルダ)を取得

oriFolder = "元データ" '★セル参照してもOK

oriCol = 4 '★元データの列(1列目から4列目までデータある前提)

strFile = Dir(strPath & "\" & oriFolder & "\" & "データ" & Format(numDate, "yyyymmdd") & ".xlsx")

’ファイル名が、データ20210125.xlsx 　の場合

’ファイル名が、データ_21年1月25日.xlsx 　の場合

’"データ_" & Format(numDate, "yy年m月d日") & ".xlsx"　とすればOK^^

Do While strFile <> ""

    Workbooks.Open strPath & "\" & oriFolder & "\" & strFile '開く

    Set wsOri = Workbooks(strFile).Worksheets("データ") '転記元のシートをセット

    oriLastRow = wsOri.Cells(Rows.Count, 1).End(xlUp).Row '1行目の最終行取得

    meLastRow = wsMe.Cells(Rows.Count, 1).End(xlUp).Row '1行目の最終行取得

    Range(wsMe.Cells(meLastRow + 1, 1), wsMe.Cells(meLastRow + oriLastRow - 1, oriCol)).Value _

    = Range(wsOri.Cells(2, 1), wsOri.Cells(oriLastRow, oriCol)).Value

    

    Range(wsMe.Cells(meLastRow + 1, oriCol + 1), wsMe.Cells(meLastRow + oriLastRow - 1, oriCol + 1)).Value = numDate

    Range(wsMe.Cells(meLastRow + 1, oriCol + 2), wsMe.Cells(meLastRow + oriLastRow - 1, oriCol + 2)).Value = strFile

    

    Workbooks(strFile).Close '閉じる

    numDate = numDate + 1

    strFile = Dir(strPath & "\" & oriFolder & "\" & "データ" & Format(numDate, "yyyymmdd") & ".xlsx")

    'strFile = Dir()

Loop

Application.ScreenUpdating = True '画面表示更新する

Application.Calculation = xlCalculationAutomatic '計算を自動に戻す

MsgBox Format(numDate - 1, "’yy/m/d") & "まで完了", vbInformation

End Sub