Two sheets Filter data results only selective column copy paste to another sheet data should not replace while pasting

Question

Could you help me for this small issue: let me explain you I have one workbook with multiple sheets

Filter apple sheet column A results one by one copy few column paste to respective given sheet in respective columns

and same need to do for Orange results one by one copy few column paste to respective given sheet in respective columns : here it is replacing data which was copied from Apple sheet

Could you please help me data while pasting should consider last row of that column and I tried all possible ways still data getting replaced

'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

You are setting `lastrow` before the data from `ws1` is pasted in. Also `ws3.Range("K5" & lastrow)` should be `ws3.Range("K" & lastrow)`. Same for other columns L and C. — CDP1802, Apr 14 '21 at 10:41
Yes I tried this option also it will delete cells and no results .... Am facing issue while pasting data second time in same sheet ... Last row is not working am struck could you please help me — Basavaraj k.s., Apr 14 '21 at 11:12

CDP1802 · Answer 1 · 2021-04-14T15:26:24.600

Determine the target row before each paste operation.

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 - swapped input / output sheets

Edit2 - check for data before copy added. Apple sheet filtered data copied to Sheet A, Orange data copied to Sheet B

Edit3 - Added sheet C,D,E. Criteria and output sheet the same.

@basav Your code shows `Destination:=ws3.Range("K5" & lastrow)` and `Set ws3 = ThisWorkbook.Sheets("Apple") `. You want to copy data from sheets Apple, Orange to A and B, correct ? — CDP1802, Apr 14 '21 at 11:38
Let's try with example that will be helpful ... Apple sheets .... Column A filter there are 'A' related rows found ... That only few columns row need to paste in A sheet special column... Next part... Orange sheets .... Column B filter there are 'A' related rows found ... That only few columns row need to paste in A sheet special n at last row ( should not replace).... same again apple sheet filter A ... Now found B rows ... Copy few column and paste in B sheet same to orange sheet — Basavaraj k.s., Apr 14 '21 at 13:52
Awesome perfectly working as per requirement ... Thank you so much — Basavaraj k.s., Apr 14 '21 at 16:01

Two sheets Filter data results only selective column copy paste to another sheet data should not replace while pasting

1 Answers1