複製多個excel文件中的列並粘貼到一個主文件中

Question

我想從多個excel文件中複製一列（始終是同一個--B3：B603），並將這些列粘貼到一個文件中，這樣我就可以將所有數據一個地方。我的宏成功搜索並將此列數據粘貼到一個空列（在我的主文件中是C3）。

當我有多個要粘貼的列時，我的宏將新列總是粘貼在同一位置（C3），因此會覆蓋以前的數據。如何使宏認識到下一列應該總是粘貼到下一個空列（如D3，E3等）。

我知道類似的問題已經被討論過了，但是我在編程方面很失敗，而且根據以前的答案我無法解決這個問題。

我當前的代碼是：

Sub LoopThroughDirectory() 
Dim MyFile As String 
Dim Filepath As String 
Filepath = "D:\DATA\" 
MyFile = Dir(Filepath) 


Do While Len(MyFile) > 0 
    If MyFile = "zmaster.xlsm" Then 
    Exit Sub 
    End If 

    Workbooks.Open (Filepath & MyFile) 
    Range("B3:B603").Copy 
    Application.DisplayAlerts = False 
    ActiveWorkbook.Close 

ActiveSheet.Paste destination:=Worksheets("Sheet1").Range("B3:B603") 

    MyFile = Dir 
Loop 
End Sub 

Answer 1

你需要在每個貼之前重新計算第一個空行，使用這樣的：

PasteRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row + 1 

試試這個：

Sub LoopThroughDirectory() 
Dim MyFile As String 
Dim Filepath As String 
Dim Wb As Workbook, _ 
    Ws As Worksheet, _ 
    PasteRow As Long 

Filepath = "D:\DATA\" 
Set Ws = ActiveSheet 
Application.DisplayAlerts = False 
Application.ScreenUpdating = False 

MyFile = Dir(Filepath) 
Do While Len(MyFile) > 0 
    If MyFile = "zmaster.xlsm" Then 
     Exit Sub 
    End If 

    PasteRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row + 1 
    Set Wb = Workbooks.Open(Filepath & MyFile) 
    Wb.Sheets(1).Range("B3:B603").Copy Destination:=Worksheets("Sheet1").Range("B" & PasteRow) 
    Wb.Close 

    MyFile = Dir 
Loop 

Application.DisplayAlerts = True 
Application.ScreenUpdating = True 
End Sub 

Answer 2

要每次都粘貼到下一列，您可以簡單地使用像這樣的計數器：

Sub LoopThroughDirectory() 
    Dim MyFile    As String 
    Dim Filepath    As String 
    Dim lNextColumn   As Long 
    Dim wsPaste    As Worksheet 

    Filepath = "D:\DATA\" 
    MyFile = Dir(Filepath) 

    Set wsPaste = ActiveSheet 
    With wsPaste 
     lNextColumn = .Cells(3, .Columns.Count).End(xlToLeft).Column 
    End With 
    Do While Len(MyFile) > 0 
     If MyFile = "zmaster.xlsm" Then 
      Exit Sub 
     End If 

     Workbooks.Open (Filepath & MyFile) 
     Range("B3:B603").Copy Destination:=wsPaste.Cells(3, lNextColumn) 
     lNextColumn = lNextColumn + 1 
     ActiveWorkbook.Close savechanges:=False 
     MyFile = Dir 
    Loop 
End Sub 

Answer 3

我簡化您的宏一點點：

Sub LoopThroughDirectory() 
Dim MyFile As String 
Dim Filepath As String 
Dim count as Integer 
Filepath = "D:\DATA\" 
MyFile = Dir(Filepath) 
count = 3 
Application.ScreenUpdating = False 

While MyFile <> "" 
    If MyFile = "zmaster.xlsm" Then Exit Sub 
    Workbooks.Open (Filepath & MyFile) 
    Workbooks(MyFile).sheets("Sheet1").Range("B3:B603").Copy thisworkbook.sheets("Sheet1").Cells(3, count) 
    Workbooks(MyFile).Close 
    count = count + 1 
    MyFile = Dir 
Loop 

Application.ScreenUpdating = True 
End Sub