请帮忙合并多个工作簿的所有列到新工作薄

dmp123

如附件所示，需要将同一文件下的3个工作薄的列提取到新工作簿，如汇总表所示，3个工作簿都只有sheet1工作表，需要将每个工作簿的A列汇总到新工作簿的sheet1，B列汇总到新工作簿的sheet2，依次类催。实际应用情况是同一文件下有几十个工作簿，每个工作簿的sheet1也有几十列。谢谢。

不知道为什么

这类代码论坛很多啊，自己变通下就可以了

不知道为什么

如图

dmp123

不知道为什么 发表于 2018-8-12 19:41
如图

能提供下代码吗，谢谢

不知道为什么

dmp123 发表于 2018-8-12 20:10
能提供下代码吗，谢谢

给忘了。代码

729211ying

Sub 多文件合并()
k = 1
Filename = Application.GetOpenFilename
b = VBA.InStrRev(Filename, "\")
folder = Left(Filename, b)
a = Dir(folder)
Do While a <> ""
   Set wb = Workbooks.Open(folder & a)
       m = wb.Worksheets(1).Cells(1, Columns.Row).End(xlToRight).Column
       If Workbooks("工作簿1").Worksheets.Count < m Then
          Workbooks("工作簿1").Worksheets.Add , Count:=m - 1
       End If
       For i = 1 To m
           wb.Worksheets(1).Columns(i).Copy Workbooks("工作簿1").Worksheets(i).Cells(1, k)
       Next
   wb.Close
   a = Dir
   k = k + 1
   Loop
End Sub
做你实际的案例可能需要自己调整一下下

729211ying

Sub 多文件合并复杂()
k = 1
Filename = Application.GetOpenFilename
b = VBA.InStrRev(Filename, "\")
folder = Left(Filename, b)
a = Dir(folder)
Do While a <> ""
   Set wb = Workbooks.Open(folder & a)
       m = wb.Worksheets(1).Cells(1, Columns.Row).End(xlToRight).Column
       If Workbooks("工作簿1").Worksheets.Count < m Then
          Workbooks("工作簿1").Worksheets.Add , Count:=m - 1
       End If
       For i = 1 To m
           wb.Worksheets(1).Columns(i).Copy Workbooks("工作簿1").Worksheets(i).Cells(1, k)
       Next
   wb.Close
   a = Dir
   k = k + 1
   Loop
End Sub

jjmysjg

不知道为什么 发表于 2018-8-12 20:35
给忘了。代码

set dic(brr(1,j)) = union(dic(brr(1,j)), .cells(2,j).resize(..........

dmp123

不知道为什么 发表于 2018-8-12 20:35
给忘了。代码

运行至Dic（k）.Copy.【a1】处，提示 要求对象

不知道为什么

dmp123 发表于 2018-8-12 22:20
运行至Dic（k）.Copy.【a1】处，提示 要求对象

copy 后面有个空格