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

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