将多个列（按不同顺序）从源工作簿复制到目标工作簿，并将其粘贴到最后一个非空行下面

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