复制多个Excel文件中的列并粘贴到一个主文件中
我想从多个excel文件中复制一列（总是同一个–B3：B603），并将这些列粘贴到一个文件中，这样我就可以将所有数据合并到一个地方。 我的macros成功search，并将这一列的数据粘贴到一个空的列（这是我的主文件中的C3）。
当我有多个列粘贴时，我的macros将新的列总是粘贴在同一位置（C3），因此会覆盖以前的数据。 如何让macros认识到下一列应该总是粘贴到下一个空列（如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 要每次都粘贴到下一列，您可以简单地使用这样的计数器：
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
我简化了你的macros：
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
您需要重新计算每个粘贴之前的第一个空行，使用以下命令：
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