Excel 2007 VBA：如何从一张纸上的动态范围复制和粘贴到另一张纸的第一行？

Question

我的问题类似于此处回答的问题（ https://stackoverflow.com/a/17071905/2506351 ），除了我需要将数据粘贴到另一张纸的第一空行上。 我已经尝试过使用lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1但这不起作用。 到目前为止，这是我完整代码的副本……

Option Explicit

Private Sub SortAndMove_Click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim lngLastRow As Long
Dim COMSheet As Worksheet, COMROLLSheet As Worksheet, CFUSheet As Worksheet, EPS2Sheet       As Worksheet, EPS3Sheet As Worksheet, ER1Sheet As Worksheet, ER2Sheet As Worksheet, FIPSheet As Worksheet, HDWSheet As Worksheet, RPS2Sheet As Worksheet, RPS3Sheet As Worksheet, RPS4Sheet As Worksheet, RR4Sheet As Worksheet, SCHSheet As Worksheet, SCHROLLSheet As Worksheet, TACSheet As Worksheet, TARSheet As Worksheet, TR1Sheet As Worksheet, TR2Sheet As Worksheet, WINSheet As Worksheet, WIN2Sheet As Worksheet, WIN3Sheet As Worksheet

Set COMSheet = Sheets("COM Data")
Set COMROLLSheet = Sheets("COM ROLL Data")
Set CFUSheet = Sheets("CFU Data") 
Set EPS2Sheet = Sheets("EPS2 Data")
Set EPS3Sheet = Sheets("EPS3 Data")
Set ER1Sheet = Sheets("ER1 Data")
Set ER2Sheet = Sheets("ER2 Data")
Set FIPSheet = Sheets("FIP Data")
Set HDWSheet = Sheets("HDW Data")
Set RPS2Sheet = Sheets("RPS2 Data")
Set RPS3Sheet = Sheets("RPS3 Data")
Set RPS4Sheet = Sheets("RPS4 Data")
Set RR4Sheet = Sheets("RR4 Data")
Set SCHSheet = Sheets("SCH Data")
Set SCHROLLSheet = Sheets("SCH ROLL Data")
Set TACSheet = Sheets("TAC Data")
Set TARSheet = Sheets("TAR Data")
Set TR1Sheet = Sheets("TR1 Data")
Set TR2Sheet = Sheets("TR2 Data")
Set WINSheet = Sheets("WIN Data")
Set WIN2Sheet = Sheets("WIN2 Data")
Set WIN3Sheet = Sheets("WIN3 Data")

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

With Range("A5", "O" & lngLastRow)
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="COM"
    .Copy COMSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="COR"
    .Copy COMROLLSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="CF1"
    .Copy CFUSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="EP2"
    .Copy EPS2Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="EP3"
    .Copy EPS3Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="ER1"
    .Copy ER1Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="ER2"
    .Copy ER2Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="FIP"
    .Copy FIPSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="HDW"
    .Copy HDWSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="RP2"
    .Copy RPS2Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="RP3"
    .Copy RPS3Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="RP4"
    .Copy RPS4Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="RR4"
    .Copy RR4Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="CH1"
    .Copy SCHSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="CR1"
    .Copy SCHROLLSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="TAC"
    .Copy TACSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="TAR"
    .Copy TARSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="TR1"
    .Copy TR1Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="TR2"
    .Copy TR2Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="WIN"
    .Copy WINSheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="W2"
    .Copy WIN2Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="W3"
    .Copy WIN3Sheet.Range("B" & .Rows.Count).End(xlUp).Row + 1
    .AutoFilter

End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

在餐饮主管的大力帮助下，我想到了以下代码作为最终代码：

Option Explicit

Private Sub Transfer_Click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim src As Worksheet
Dim lngLastRow As Long
Dim tgtCom As Worksheet
Dim tgtLRCom As Long
Dim tgtComRoll As Worksheet
Dim tgtLRComRoll As Long
Dim tgtCFU As Worksheet
Dim tgtLRCFU As Long
Dim tgtEPS2 As Worksheet
Dim tgtLREPS2 As Long
Dim tgtEPS3 As Worksheet
Dim tgtLREPS3 As Long
Dim tgtER1 As Worksheet
Dim tgtLRER1 As Long
Dim tgtER2 As Worksheet
Dim tgtLRER2 As Long
Dim tgtFIP As Worksheet
Dim tgtLRFIP As Long
Dim tgtHDW As Worksheet
Dim tgtLRHDW As Long
Dim tgtRPS2 As Worksheet
Dim tgtLRRPS2 As Long
Dim tgtRPS3 As Worksheet
Dim tgtLRRPS3 As Long
Dim tgtRPS4 As Worksheet
Dim tgtLRRPS4 As Long
Dim tgtRR4 As Worksheet
Dim tgtLRRR4 As Long
Dim tgtSCH As Worksheet
Dim tgtLRSCH As Long
Dim tgtSCHROLL As Worksheet
Dim tgtLRSCHROLL As Long
Dim tgtTAC As Worksheet
Dim tgtLRTAC As Long
Dim tgtTAR As Worksheet
Dim tgtLRTAR As Long
Dim tgtTR1 As Worksheet
Dim tgtLRTR1 As Long
Dim tgtTR2 As Worksheet
Dim tgtLRTR2 As Long
Dim tgtWIN As Worksheet
Dim tgtLRWIN As Long
Dim tgtWIN2 As Worksheet
Dim tgtLRWIN2 As Long
Dim tgtWIN3 As Worksheet
Dim tgtLRWIn3 As Long

Set wb = ThisWorkbook
Set src = wb.Sheets("Transfer")
Set tgtCom = wb.Sheets("COM Data ")
Set tgtComRoll = wb.Sheets("COM ROLL Data")
Set tgtCFU = wb.Sheets("CFU Data")
Set tgtEPS2 = wb.Sheets("EPS2 Data")
Set tgtEPS3 = wb.Sheets("EPS3 Data")
Set tgtER1 = wb.Sheets("ER1 Data")
Set tgtER2 = wb.Sheets("ER2 Data")
Set tgtFIP = wb.Sheets("FIP Data")
Set tgtHDW = wb.Sheets("HDW Data")
Set tgtRPS2 = wb.Sheets("RPS2 Data")
Set tgtRPS3 = wb.Sheets("RPS3 Data")
Set tgtRPS4 = wb.Sheets("RPS4 Data")
Set tgtRR4 = wb.Sheets("RR4 Data")
Set tgtSCH = wb.Sheets("SCH Data")
Set tgtSCHROLL = wb.Sheets("SCH ROLL Data")
Set tgtTAC = wb.Sheets("TAC Data")
Set tgtTAR = wb.Sheets("TAR Data")
Set tgtTR1 = wb.Sheets("TR1 Data")
Set tgtTR2 = wb.Sheets("TR2 Data")
Set tgtWIN = wb.Sheets("WIN Data")
Set tgtWIN2 = wb.Sheets("WIN2 Data")
Set tgtWIN3 = wb.Sheets("WIN3 Data")

lngLastRow = Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRCom = tgtCom.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRComRoll = tgtComRoll.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRCFU = tgtCFU.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLREPS2 = tgtEPS2.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLREPS3 = tgtEPS3.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRER1 = tgtER1.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRER2 = tgtER2.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRFIP = tgtFIP.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRHDW = tgtHDW.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRRPS2 = tgtRPS2.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRRPS3 = tgtRPS3.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRRPS4 = tgtRPS4.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRRR4 = tgtRR4.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRSCH = tgtSCH.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRSCHROLL = tgtSCHROLL.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRTAC = tgtTAC.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRTAR = tgtTAR.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRTR1 = tgtTR1.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRTR2 = tgtTR2.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRWIN = tgtWIN.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRWIN2 = tgtWIN2.Cells(Rows.Count, "B").End(xlUp).Row + 1
tgtLRWIn3 = tgtWIN3.Cells(Rows.Count, "B").End(xlUp).Row + 1

With src.Range("A4", "O" & lngLastRow)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="COM"
.Copy tgtCom.Range("B" & tgtLRCom)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="COR"
.Copy tgtComRoll.Range("B" & tgtLRComRoll)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="CF1"
.Copy tgtCFU.Range("B" & tgtLRCFU)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="EP2"
.Copy tgtEPS2.Range("B" & tgtLREPS2)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="EP3"
.Copy tgtEPS3.Range("B" & tgtLREPS3)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="ER1"
.Copy tgtER1.Range("B" & tgtLRER1)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="ER2"
.Copy tgtER2.Range("B" & tgtLRER2)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="FIP"
.Copy tgtFIP.Range("B" & tgtLRFIP)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="HDW"
.Copy tgtHDW.Range("B" & tgtLRHDW)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="RPS2"
.Copy tgtRPS2.Range("B" & tgtLRRPS2)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="RP3"
.Copy tgtRPS3.Range("B" & tgtLRRPS3)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="RP4"
.Copy tgtRPS4.Range("B" & tgtLRRPS4)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="RR4"
.Copy tgtRR4.Range("B" & tgtLRRR4)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="CH1"
.Copy tgtSCH.Range("B" & tgtLRSCH)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="CR1"
.Copy tgtSCHROLL.Range("B" & tgtLRSCHROLL)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="TAC"
.Copy tgtTAC.Range("B" & tgtLRTAC)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="TAR"
.Copy tgtTAR.Range("B" & tgtLRTAR)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="TR1"
.Copy tgtTR1.Range("B" & tgtLRTR1)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="TR2"
.Copy tgtTR2.Range("B" & tgtLRTR2)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="WIN"
.Copy tgtWIN.Range("B" & tgtLRWIN)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="W2"
.Copy tgtWIN2.Range("B" & tgtLRWIN2)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="W3"
.Copy tgtWIN3.Range("B" & tgtLRWIn3)
.AutoFilter

End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

您需要在目标工作表（而不是活动工作表）上找到最后一个空行。

更改此：

lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

对此：

dim tgt as Worksheet
' specify the sheet you want to paste into here
set tgt = Sheets("COM Data")
lastRow = tgt.Cells(Rows.Count, "A").End(xlUp).Row + 1

我建议简化您的工作，直到您了解它，然后将其应用于生产代码。 以下内容将帮助您对代码进行故障排除，以便对其进行修复。

打开一个新的工作簿，并在单元格A1，A2和A3中键入值。 键入什么都无关紧要，我们只需要处理一些内容即可。

现在添加一个模块并粘贴以下代码：

Sub CopyToEndOfColumnOnAnotherSheet()
    Dim wb As Workbook
    Dim src As Worksheet
    Dim tgt As Worksheet
    Dim tgtLastRow As Long

    Set wb = ThisWorkbook
    Set src = wb.Sheets("Sheet1")
    Set tgt = wb.Sheets("Sheet2")

    tgtLastRow = tgt.Cells(Rows.Count, "A").End(xlUp).Row + 1
    src.Range("A1:A3").Copy tgt.Range("A" & tgtLastRow)
End Sub

每次运行它时，Sheet1中的3个值将被复制到Sheet2中范围的末尾。