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

Question

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

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
• lngRow = lngRow + 1的With wb.Sheets("Open Issue Actions")
• 后粘贴值应该是这样的.Cells(lngRow, myCol).PasteSpecial xlPasteValues

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

的想法是有lngRow并增加它每次打开工作表。不要做任何事情。

在一般情况下，你的代码可以在某些方面进行优化，如果工程变更确定后，把它放在这里进行进一步的想法：https://codereview.stackexchange.com/