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

要每次粘贴到下一列，您只需使用这样的计数器：

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 2

我简化了你的宏：

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

Answer 3

您需要在每次粘贴之前重新计算第一个空闲行，使用：

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

从多个excel文件复制列并粘贴到一个主文件中

3 个答案: