两张表过滤数据结果仅选择性列复制粘贴到另一张表数据粘贴时不应替换

Question

你能帮我解决这个小问题吗：让我解释一下我有一个包含多张工作表的工作簿

过滤苹果工作表A列结果一一复制几列粘贴到各个列中的相应给定工作表

同样需要为 Orange 结果一一复制几列粘贴到相应列中的相应给定工作表：这里它正在替换从 Apple 工作表复制的数据

您能否帮我粘贴数据时考虑该列的最后一行，我尝试了所有可能的方法仍然数据被替换

'Assign and set your variables

Sub data()

    'Application.ScreenUpdating = False
    'Application.CutCopyMode = True

    'Declare variable and give sheet names
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, lRow As Long, lastrow As Long

    ' for example am showing only two sheet actualy i have lot of sheets here ( i dont know how it can be loop)
    Set ws1 = ThisWorkbook.Sheets("A")
    Set ws2 = ThisWorkbook.Sheets("B")
    Set ws3 = ThisWorkbook.Sheets("Apple") 
    Set ws4 = ThisWorkbook.Sheets("Orange")

    'Declare for last row
    Dim InputBox As String
    lRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    lastrow = ws3.Cells(ws3.Rows.Count, 10).End(xlUp).Row

    'Apple and orange sheet name header start from 4th row
    Sheets("Apple").Select
    Rows("4:36" & lRow).Clear

    Sheets("Orange").Select
    Rows("4:36" & lRow).Clear

    With ws1

        .Range("A1:Q1").AutoFilter Field:=1, Criteria1:="apple"
        .Range("J2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws3.Range("c4")
        .Range("P2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws3.Range("L4")
        .Range("Q2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws3.Range("K4")
        .Range("A1").AutoFilter 'clear the filter

        .Range("A1:Q1").AutoFilter Field:=1, Criteria1:="orange"
        .Range("J2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws4.Range("c4")
        .Range("P2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws4.Range("L4")
        .Range("Q2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws4.Range("K4")
        .Range("A1").AutoFilter 'clear the filter

    End With

'Below am not getting low row and while paste ( it is replacing old data)

    With ws2

        .Range("A1:S1").AutoFilter Field:=2, Criteria1:="apple"
        .Range("H2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws3.Range("K5" & lastrow)
        .Range("I2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws3.Range("L4")
        .Range("S2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws3.Range("C4")
        .Range("B1").AutoFilter 'clear the filter

        .Range("A1:S1").AutoFilter Field:=2, Criteria1:="Orange"
        .Range("H2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws4.Range("K4")
        .Range("I2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws4.Range("L4")
        .Range("S2").Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws4.Range("C4")
        .Range("B1").AutoFilter 'clear the filter

    End With
End Sub

Answer 1

在每次粘贴操作之前确定目标行。

Option Explicit

Sub data()

    Dim wb As Workbook, wsOut As Worksheet
    Dim n As Integer, lastRow As Long, targetRow As Long
    Dim arCrit, arOut, rng As Range

    Set wb = ThisWorkbook
    arCrit = Array("A", "B", "C", "D", "E")
    arOut = Array("A", "B", "C", "D", "E")

    'clear output sheets
    For n = 0 To UBound(arOut)
        Set wsOut = wb.Sheets(arOut(n))
        lastRow = wsOut.Cells(Rows.Count, "C").End(xlUp).Row
        If lastRow > 3 Then
            wsOut.Rows("4:" & lastRow).Clear
        End If
    Next

    With wb.Sheets("Apple") ' source
        
        ' filter/copy on each criteria A to Sheet A, B to Sheet B etc
        For n = 0 To UBound(arCrit)
            Set wsOut = wb.Sheets(arOut(n)) ' destination sheet A,B,C,D,E
            lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
            .Range("A1:Q1").AutoFilter Field:=1, Criteria1:=arCrit(n)

            ' check for data
            Set rng = .Range("A1:Q" & lastRow).SpecialCells(xlCellTypeVisible)
            If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then
                targetRow = wsOut.Cells(wsOut.Rows.Count, "C").End(xlUp).Row + 1
                .Range("J2").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wsOut.Range("C" & targetRow)
                .Range("P2").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wsOut.Range("L" & targetRow)
                .Range("Q2").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wsOut.Range("K" & targetRow)
            End If
            .Range("A1").AutoFilter 'clear the filter
        Next
    End With

    With wb.Sheets("Orange") ' source

        ' filter/copy on each criteria A to Sheet A, B to Sheet B etc
        For n = 0 To UBound(arCrit)
            Set wsOut = wb.Sheets(arOut(n)) ' destination sheet
            lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
            .Range("A1:S1").AutoFilter Field:=2, Criteria1:=arCrit(n)
          
            ' check for data
            Set rng = .Range("A1:S" & lastRow).SpecialCells(xlCellTypeVisible)
            If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then
                 targetRow = wsOut.Cells(wsOut.Rows.Count, "C").End(xlUp).Row + 1
                .Range("H2").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wsOut.Range("K" & targetRow)
                .Range("I2").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wsOut.Range("C" & targetRow)
                .Range("S2").Resize(lastRow - 1).SpecialCells(xlCellTypeVisible).Copy wsOut.Range("L" & targetRow)
             End If
             .Range("B1").AutoFilter 'clear the filter
        Next
    End With

    MsgBox "End"
End Sub

Edit1 - 交换输入/输出表

Edit2 - 在添加副本之前检查数据。苹果表过滤数据复制到表 A，橙色数据复制到表 B

Edit3 - 添加了工作表 C、D、E。标准和输出表相同。