074_Excel VBA_自動転記編

みなさん、こんにちは、たなぴーです！

今回紹介したコードは下記になりますので、活用してみてください^^
(Excelの形、シート名など、同じもの作るのは大変かも？？)
自分なりにアレンジしてみましょう！

------------------------------------------------------------------------------------
Option Explicit

Sub DataInput()
Dim i As Integer '転記先の行数を取得
Dim strPath As String '本ファイルのパス(フォルダ)
Dim wsMe As Worksheet '本ファイル 転記先のシート
Dim strFile As String '転記元のフォームのファイル名
Dim wsForm As Worksheet '転記元のシート

Application.ScreenUpdating = False '画面表示更新をストップする
Application.Calculation = xlCalculationManual '計算を手動に

Set wsMe = ThisWorkbook.Worksheets("集計")
strPath = ThisWorkbook.Path '本ファイルのパス(フォルダ)を取得

i = 5 '5行目以降が入力箇所
Do While wsMe.Cells(i, 1) <> "" 'データ未入力の行まで進む
    i = i + 1
Loop

strFile = Dir(strPath & "\フォーム回収\" & "*")

Do While strFile <> ""
    Workbooks.Open strPath & "\フォーム回収\" & strFile '開く
    Set wsForm = Workbooks(strFile).Worksheets("申込フォーム") '転記元のシートをセット
    wsMe.Cells(i, 1).Value = wsForm.Cells(5, 4).Value
    wsMe.Cells(i, 2).Value = wsForm.Cells(5, 5).Value
    wsMe.Cells(i, 3).Value = wsForm.Cells(6, 4).Value
    wsMe.Cells(i, 4).Value = wsForm.Cells(6, 5).Value
    wsMe.Cells(i, 5).Value = wsForm.Cells(8, 4).Value
    wsMe.Cells(i, 6).Value = wsForm.Cells(9, 4).Value
    wsMe.Cells(i, 7).Value = wsForm.Cells(10, 4).Value
    wsMe.Cells(i, 8).Value = wsForm.Cells(12, 3).Value
    wsMe.Cells(i, 9).Value = wsForm.Cells(12, 5).Value
 
    wsMe.Cells(i, 10).Value = strFile 'ファイル名
    wsMe.Cells(i, 11).Value = Now() '日付/時刻
 
    Workbooks(strFile).Close '閉じる
    strFile = Dir()
    i = i + 1
Loop

Application.ScreenUpdating = True '画面表示更新する
Application.Calculation = xlCalculationAutomatic '計算を自動に戻す
MsgBox "完了", vbInformation
End Sub