Question

有没有办法按列合并多个Excel电子表格中的数据？

我有200个电子表格，每个电子表格在前100列（A-CV）中都有文字。我想合并所有＆＃34; A＆＃34;这200个文件中的列，所有＆＃34; B＆＃34;列一起，所有＆＃34; C＆＃34;列一起，等等。

至于合并，不需要特定的订单。只要细胞本身不合并。

由于代码将合并大量文本，因此能够将所有电子表格中的一列合并为唯一文件更为实际，然后对所有其他列重复（A-CV）），而不是尝试将所有列（从所有电子表格）合并到一个文件中。

我发现了一个合并列的代码，但它并不是我需要的。有没有办法修改此代码以帮助我上面描述的内容？

Sub Macro1()
'
' Macro1 Macro
'

    Dim cell As Range
    For i = 1 To 50
        Sheets("Sheet1").Select
        If Cells(1, i).Value = "Cat 2" Then
        Columns(i).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("A1").Select
        ActiveSheet.Paste
        End If
        If Cells(1, i).Value = "Cat 6" Then
        Columns(i).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("B1").Select
        ActiveSheet.Paste
        End If
        If Cells(1, i).Value = "Cat 4" Then
        Columns(i).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("C1").Select
        ActiveSheet.Paste
        End If
    Next i
End Sub

如果您需要更多信息，请告诉我们。如果我需要以某种方式重命名文档以帮助完成此过程，我绝对愿意这样做。

合并的数据可以发送到电子表格，Word文档或记事本。我对任何这些选项都没问题。

更新：这是修改后的新代码。我遇到的问题在下面的评论中。

 Sub copydocument()
 Dim wb As Workbook
 Dim wb1 As Workbook
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 On Error GoTo resetsettings
 Set wb = ThisWorkbook
 MyPath = "C:\Users\HNR\Desktop\A\" 'Path of folder with \ at the end
 MyExtension = "*.xlsx"
 Myfile = Dir(MyPath & MyExtension)
 While Myfile <> vbNullString
 Set wb1 = Workbooks.Open(MyPath & Myfile)
 lr = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
 lr1 = wb1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
 wb1.Sheets(1).Range("A" & lr1).Copy Destination:=wb.Sheets(1).Range("A" & (lr + 1))
 wb1.Close
Myfile = Dir
Wend
resetsettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

虽然有很多方法可以做你想要的，但我建议你查看Power Query。它为您提供了一个很好的GUI来完成这项工作。根据您的excel版本，它可以是免费附加组件，也可以是已发布产品的一部分（适用于新版本的办公室）。

您不需要知道如何编写代码来使用它，您只需要理解这些概念。

虽然在我成功地在我的工作场所教过几个人之后，你的答案并不完全是如何使用这个以前依赖我或其他有VBA技能的人的应用程序。

Answer 2

Sub copydocument()
Dim wb As Workbook
Dim wb1 As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo resetsettings
Set wb = ThisWorkbook
MyPath = "c:\Users\foo\" 'Path of folder with \ at the end
MyExtension = "*.xlsx"
Myfile = Dir(MyPath & MyExtension)
While Myfile <> vbNullString
Set wb1 = Workbooks.Open(MyPath & Myfile)
lr = wb.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row
lr1 = wb1.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row
wb1.Sheets(1).Range("A1:CV" & lr1).Copy Destination:=wb.Sheets(1).Range("A" & (lr + 1))
wb1.close
Myfile = Dir
Wend
resetsettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

此宏将遍历文件夹中的所有文件并复制sheet1范围并将其粘贴到活动工作簿sheet1中。如果您有标题并且不希望它们重复，您可以将标题复制到activeworkbook的sheet1，然后从（A2：CV＆amp; lr1）复制范围。

用于按列合并多个文档中的数据的代码

2 个答案: