如何将同结构多工作簿数据按列间隔批量导入至目标工作簿？

问题说明 #

现有VBA宏可批量读取指定文件夹内结构一致的工作簿数据，但每次循环都将数据写入固定位置，需要实现每次处理文件后粘贴区域自动偏移11列（10列数据块+1列间隔）：

• 首次：源A1:J168 → 目标A4:J171；源P10 → 目标J4
• 第二次：源A1:J168 → 目标L4:U171；源P10 → 目标U4
• 后续以此类推，直至处理完所有文件

修改后的完整代码 #

Option Explicit

Const FOLDER_PATH = "C:\Users\mapetr\Desktop\Duomenys\"  '记得修改路径

Private Sub CommandButton1_Click()

   Dim sFile As String
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource1 As Worksheet
   Dim wsSource2 As Worksheet
   Dim colOffset As Integer '新增：记录列偏移量

   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "指定文件夹不存在，程序退出！"
      Exit Sub
   End If

   On Error GoTo errHandler
   Application.ScreenUpdating = False

   Set wsTarget = Sheets("Routings (fin)")
   colOffset = 0 '初始化偏移量为0

   sFile = Dir(FOLDER_PATH & "*.xls*")
   Do Until sFile = ""
  
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource1 = wbSource.Worksheets("Summary for finance")
      Set wsSource2 = wbSource.Worksheets("PBA box build cost calculation")
  
      '数据导入：动态计算目标区域
      With wsTarget
         '源A1:J168 → 目标起始行4，起始列1+偏移量，保持168行10列
         .Cells(4, 1 + colOffset).Resize(168, 10).Value = wsSource1.Range("A1:J168").Value
         '源P10 → 目标起始行4，列10+偏移量（对应数据块最后一列）
         .Cells(4, 10 + colOffset).Value = wsSource2.Range("P10").Value
      End With
  
      wbSource.Close SaveChanges:=False
      sFile = Dir()
      colOffset = colOffset + 11 '每次循环后偏移量增加11（10列数据+1列间隔）
   Loop

errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True

   Set wsSource1 = Nothing
   Set wsSource2 = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub


Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

关键修改点 #

• 新增colOffset变量：用于累计每次循环的列偏移量，初始值为0，处理完一个文件后增加11
• 替换固定Range地址：使用.Cells(行号, 列号).Resize(行数, 列数)动态生成目标区域，确保每次循环的粘贴位置自动偏移
• 保持原有文件遍历、错误处理逻辑不变，仅修改数据写入部分，保证兼容性

内容的提问来源于stack exchange，提问作者MrXPs