多表数据添加

1005423860

如附件所示，点击数据源的“添加”按钮 将数据加入同文件夹的表1里

sub麻辣君

解法一：常规赋值
Sub test非数组解法()
   Dim rng As Range, i%
   Workbooks.Open (ThisWorkbook.Path & "\表1.xlsx")
   i = Workbooks("表1.xlsx").Sheets(1).[a1048576].End(xlUp).Row + 1
   ThisWorkbook.Activate
   For Each rng In ThisWorkbook.Sheets(1).Range("a3", [a1048576].End(xlUp))
      Workbooks("表1.xlsx").Sheets(1).Cells(i, 1) = Workbooks("表1.xlsx").Sheets(1).Cells(i, 1).Offset(-1, 0) + 1
      Workbooks("表1.xlsx").Sheets(1).Cells(i, 2) = rng.Value
      Workbooks("表1.xlsx").Sheets(1).Cells(i, 4) = rng.Offset(0, 1).Value
      i = i + 1
   Next
End Sub

sub麻辣君

解法二：数组字典
Sub test数组解法()
   Dim rng As Range, dic, arr, brr, crr(), i%
   Workbooks.Open (ThisWorkbook.Path & "\表1.xlsx")
   i = Workbooks("表1.xlsx").Sheets(1).[a1048576].End(xlUp).Value + 1
   ThisWorkbook.Activate
   Set dic = CreateObject("scripting.dictionary")
   For Each rng In ThisWorkbook.Sheets(1).Range("a3", [a1048576].End(xlUp))
      dic(i) = rng.Value & "," & " " & "," & rng.Offset(0, 1): i = i + 1
   Next
   brr = dic.items
   ReDim crr(0 To UBound(brr))
   For j = 0 To UBound(brr)
      crr(j) = Split(brr(j), ",")
   Next j
   Workbooks("表1.xlsx").Sheets(1).[a1048576].End(xlUp).Offset(1, 0).Resize(j, 1) = Application.Transpose(dic.keys)
   Workbooks("表1.xlsx").Sheets(1).[b1048576].End(xlUp).Offset(1, 0).Resize(j, 3) = Application.Transpose(Application.Transpose(crr))
End Sub

sub麻辣君

当然，条条大路通罗马，不唯一，看个人习惯以及能简化的最优方式