質問: お恥ずかしいながら、VBA初心者で、現在ものすごく困っております。 VBAでの転記について教えてください
回答: Option Explicit Const 転記元_フォルダ$ = "C:\Users\hoge\Desktop\転記元" Const 転記元_拡張子$ = "xls" Const 転記元_シート名$ = "Sheet1" Const 転記元_開始行& = 2 Const 転記元_開始列$ = "A" Const 転記元_終了列$ = "E" Const 転記先_シート名$ = "Sheet1" Const 転記先_開始行& = 2 Const 転記先_開始列$ = "A" Const 転記先_終了列$ = "E" Const 転記先_オフセット& = 2 Private 転記先シート As Worksheet Private FSO As Object Private 転記データ As Object Private 転記先行位置& Public Sub 転記() Call 初期化 If FSO.FolderExists(転記元_フォルダ) = False Then MsgBox "フォルダが見つかりません" Exit Sub End If Call 転記元データ収集 Call シートに転記 End Sub Private Sub 初期化() Set 転記先シート = ThisWorkbook.Sheets(転記先_シート名) Set FSO = CreateObject("Scripting.FileSystemObject") Set 転記データ = CreateObject("Scripting.Dictionary") 転記先行位置 = 転記先_開始行 End Sub Private Sub 転記元データ収集() Dim ファイル As Object For Each ファイル In FSO.GetFolder(転記元_フォルダ).Files Dim データ If 転記元データをゲット(ファイル.Path, データ) Then 転記データ.Add FSO.GetBaseName(ファイル.Path), データ End If Next End Sub Private Function 転記元データをゲット(パス$, データ) As Boolean If FSO.GetExtensionName(パス) <> 転記元_拡張子 Then Exit Function On Error GoTo errorHandler1 Dim ブック As Workbook Set ブック = Workbooks.Open(パス) On Error GoTo errorHandler2 Dim シート As Worksheet Set シート = ブック.Worksheets(転記元_シート名) Dim 最終行& 最終行 = シート.Cells(Rows.Count, 転記元_開始列).End(xlUp).Row データ = シート.Range( _ シート.Cells(転記元_開始行, 転記元_開始列), _ シート.Cells(最終行, 転記元_終了列)) ブック.Close 転記元データをゲット = True Exit Function errorHandler1: Exit Function errorHandler2: ブック.Close End Function Private Sub シートに転記() Dim キー For Each キー In 転記データ Dim データ: データ = 転記データ(キー) Dim データ行数&: データ行数 = UBound(データ) - 1 Dim 最終行&: 最終行 = 転記先行位置 + データ行数 With 転記先シート Dim ブック名範囲 As Range Set ブック名範囲 = _ .Range(.Cells(転記先行位置, 転記先_開始列), _ .Cells(最終行, 転記先_開始列)) ブック名範囲 = キー Dim 転記先セル範囲 As Range Set 転記先セル範囲 = _ .Range(.Cells(転記先行位置, 転記先_開始列), _ .Cells(最終行, 転記先_終了列)) 転記先セル範囲.Offset(, 1) = データ End With 転記先行位置 = 最終行 + 転記先_オフセット Next End Sub