複製多個電子表格中的列。當電子表格中的列爲空時，數據向上移動

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/