通過列合併多個文檔中的數據的代碼

Question

是否有一種方法可以將多個Excel電子表格中的數據按列合併在一起？

我有200個電子表格，每個電子表格在前100列（A-CV）中都有。 我想合併這200個文檔中的所有「A」列，所有「B」列合併在一起，所有「C」列合併在一起，等等。

至於合併，不需要特定的順序。只要細胞本身不合並。

由於代碼將會合並大量文本，因此能夠將所有電子表格中的一列一次合併到一個唯一文件中，然後在所有其他列（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。它給你一個很棒的圖形用戶界面來完成這個任務。根據您的Excel版本，它可以是免費的附加組件或已發貨產品的一部分（適用於新版本的Office）。

你不需要知道如何使用這個代碼，你只需要瞭解這些概念。

雖然它並不完全是你在我成功地教過我的工作地點的幾個人之後的答案如何使用此應用程序以前一直依賴於我或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的工作表1，然後從（A2：CV & lr1）複製範圍。