將多列（以不同順序）從源工作簿復制到目標工作簿，並將其粘貼到最后一個非空行下方

Question

我有兩個不同的工作簿，分別名為Input.xlsb （源數據）和Lapsed Pipeline.xlsm（目標工作簿）。 我在這里搜索了代碼，發現其中一個對我有部分幫助，但是此代碼的問題是一列的數據粘貼到了另一列的下面。 例如：D列正確粘貼到最后一個非空單元格中，但列中的數據粘貼到列中數據之后的最后一行中，對於每列都一樣，我希望源數據中的所有數據都粘貼到最后一個非空之后空行一次。 以下是我出於目的對代碼進行了重新編輯。

例：

Sub CopyCoverage()

Dim x As Worksheet, y As Worksheet, LastRow&

Set x = Workbooks("Input.xlsb").Worksheets("Opportunity")
Set y = ThisWorkbook.Worksheets("Lapsed Opps")

LastRow = x.Cells.SpecialCells(xlCellTypeLastCell).Row

x.Range("G2:G" & LastRow).Copy y.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)     
x.Range("I2:I" & LastRow).Copy y.Cells(Rows.Count, "M").End(xlUp).Offset(1, 0)    
x.Range("P2:P" & LastRow).Copy y.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)    
x.Range("Y2:Y" & LastRow).Copy y.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)    
x.Range("Z2:Z" & LastRow).Copy y.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)    
x.Range("AJ2:AJ" & LastRow).Copy y.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)    
x.Range("AK2:AK" & LastRow).Copy y.Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)    
x.Range("AL2:AL" & LastRow).Copy y.Cells(Rows.Count, "I").End(xlUp).Offset(1, 0)    
x.Range("AM2:AM" & LastRow).Copy y.Cells(Rows.Count, "J").End(xlUp).Offset(1, 0)     
x.Range("EC2:EC" & LastRow).Copy y.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)     
x.Range("EG2:EG" & LastRow).Copy y.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)     

Application.CutCopyMode = False

End Sub

Answer 1

而不是使用的Rows.Count和End(xlUp)存儲的底行UsedRange在一個變量，你開始復印之前：

Dim PasteRow AS Long
PasteRow = y.UsedRange.Rows(y.UsedRange.Rows.Count).Row + 1
x.Range("G2:G" & LastRow).Copy y.Cells(PasteRow, 4)  'Do not change PasteRow
x.Range("I2:I" & LastRow).Copy y.Cells(PasteRow, 13)  'et cetera

{EDIT}較長的代碼，刪除了對UsedRange的要求，仍然接受某些列可能包含空白單元格：

'This replaces your Copy block - everything before stays as you wrote it
Dim PasteRow As Long, iCheckCol AS Integer
PasteRow = 0
For iCheckCol = 1 to 10 'Check columns A - J
    If y.Cells(y.Rows.Count, iCheckCol).End(xlUp).Row > PasteRow Then
        PasteRow = y.Cells(y.Rows.Count, iCheckCol).End(xlUp).Row 'Find lowest bottom of rows
    End If
Next iCheckCol
PasteRow = PasteRow+1 'Go down from the Bottom Row
x.Range("G2:G" & LastRow).Copy y.Cells(PasteRow, 4)  'Do not change PasteRow
x.Range("I2:I" & LastRow).Copy y.Cells(PasteRow, 13)  'et cetera
'Add a line for every column that you want to copy

Answer 2

如果我理解正確，以下內容如何：

Sub CopyCoverage()

Dim x As Worksheet, y As Worksheet, LastRow&, yLastRow&

Set x = Workbooks("Input.xlsb").Worksheets("Opportunity")
Set y = ThisWorkbook.Worksheets("Lapsed Opps")

LastRow = x.Cells.SpecialCells(xlCellTypeLastCell).Row
yLastRow = y.Cells(y.Rows.Count, "A").End(xlUp).Row + 1

x.Range("G2:G" & LastRow).Copy y.Cells(yLastRow, "D").End(xlUp)
x.Range("I2:I" & LastRow).Copy y.Cells(yLastRow, "M").End(xlUp)
x.Range("P2:P" & LastRow).Copy y.Cells(yLastRow, "A").End(xlUp)
x.Range("Y2:Y" & LastRow).Copy y.Cells(yLastRow, "C").End(xlUp)
x.Range("Z2:Z" & LastRow).Copy y.Cells(yLastRow, "B").End(xlUp)
x.Range("AJ2:AJ" & LastRow).Copy y.Cells(yLastRow, "G").End(xlUp)
x.Range("AK2:AK" & LastRow).Copy y.Cells(yLastRow, "H").End(xlUp)
x.Range("AL2:AL" & LastRow).Copy y.Cells(yLastRow, "I").End(xlUp)
x.Range("AM2:AM" & LastRow).Copy y.Cells(yLastRow, "J").End(xlUp)
x.Range("EC2:EC" & LastRow).Copy y.Cells(yLastRow, "F").End(xlUp)
x.Range("EG2:EG" & LastRow).Copy y.Cells(yLastRow, "E").End(xlUp)

Application.CutCopyMode = False

End Sub