复制多个电子表格中的列。 当电子表格上的列为空时，数据向上移动

我有下面的代码。 代码将进入17个工作簿中的每一个，并根据列标题名称提取某些列。 这将重复并添加到主工作簿的底部，直到最后一个被提取。 不幸的是，如果其中一个单独的工作簿中的某一列中没有任何内容，则下一个工作簿中的数据会在单元格中向上移动。 无论如何要sorting这个。 我已经添加了下面的代码。

Option Explicit Sub CopyColumns() Dim CopyFromPath As String, FileName As String Dim CopyToWb As Workbook, wb As Workbook, CopyToWs As Worksheet Dim lastRow As Long, NextRow As Long, lcol As Long, c As Long, sv As Integer Dim ws As Worksheet Dim myCol As Long Dim myHeader As Range r\" Set CopyToWb = ActiveWorkbook Set c).End(xlUp).Row If lastRow = 1 Then GoTo nxt Range(Cells(2, c), Cells(lastRow, c)).Copy CopyToWs.Activate Set myHeader = CopyToWs.Rows(1).Find(What:=.Cells(1, c).Value, Lookat:=xlWhole) With CopyToWs If Not myHeader Is Nothing Then myCol = myHeader.Column NextRow = .Cells(Rows.Count, myCol).End(xlUp).Row + 1 .Cells(NextRow, myCol).PasteSpecial xlPasteValues Application.CutCopyMode = False Set myHeader = Nothing End If nxt: End With End If Next c wb.Close saveChanges:=False End With FileName = Dir Loop Application.ScreenUpdating = True End Sub 

先谢谢你

Answer 1

每个工作簿只计算一次NextRow ，然后将其用于所有列：

 Do While Len(FileName) > 0 'Calculate the next row to be populated for all columns, based on the last 'used cell in column A '(I used column A, but pick whatever destination column will always be 'populated in every workbook.) With CopyToWs NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 End With 'Process this workbook Set wb = Workbooks.Open(CopyFromPath & FileName) With wb.Sheets("Open Issue Actions") lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column For c = 1 To lcol '... With CopyToWs If Not myHeader Is Nothing Then myCol = myHeader.Column 'NextRow = .Cells(Rows.Count, myCol).End(xlUp).Row + 1 .Cells(NextRow, myCol).PasteSpecial xlPasteValues Application.CutCopyMode = False Set myHeader = Nothing End If End With nxt: '... 

Answer 2

其实你想每张纸一行。 没有其他的。 而已。 你甚至不需要计算它。 你需要增加它lngRow = lngRow+1 。 尝试在你的代码中使用以下内容：

 Option Explicit Sub CopyColumns() Dim lngRow As Long: lngRow = 1 Do While Len(FileName) > 0 Set wb = Workbooks.Open(CopyFromPath & FileName) With wb.Sheets("Open Issue Actions") lngRow = lngRow + 1 With CopyToWs If Not myHeader Is Nothing Then myCol = myHeader.Column .Cells(lngRow, myCol).PasteSpecial xlPasteValues Set myHeader = Nothing End If End With End With wb.Close saveChanges:=False Loop Application.ScreenUpdating = True End Sub 

在代码中添加/编辑三件事情：

• The line Dim lngRow as Long: lngRow=1 ，另一个Dim
• With wb.Sheets("Open Issue Actions")之后的lngRow = lngRow + 1
• 粘贴值应该像这样.Cells(lngRow, myCol).PasteSpecial xlPasteValues

整个代码在这里： https ： //pastebin.com/kXdzkGZ1

这个想法是让lngRow为每个打开的WorkSheet增加它。 不要做任何事情。

一般来说，你的代码可以在某些方面进行优化，如果改变后它可以正常工作，可以在这里提出更多的build议： https : //codereview.stackexchange.com/