VBA code to cut and paste multiple filtered rows based on multiple criteria

[BrerRabbit]

I have been trying to sort out what is going wrong with my code and can't see where it is going wrong.

I have sourced an answer to this question but the answer doesn't seem to be working for me.

The code is generated from the Table of Contents worksheet, filtering and cutting data from the ParticipantWS worksheet and pasting to the ArchivedParticipants worksheet.

lngRow - counting teh empty rows in teh ArchivedParticipants it is counting table cells as full, so the count is after the table.
lngCount = lngCount = WsSrc.Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count returns a value of one, even though there are two filtered rows. I'm assuming this line is to count the number of filtered lines other than the header row. And yes, this is in a table.

The data that is to be pasted into the Archived Participant worksheet needs to be pasted as values as there are formula contrived values here. The table in the ParticipantWS is over 400 columns wide.

Can someone help please?

macro to cut & paste rows to another sheet (with multiple criteria) - vba

Sub Macro5()

    Dim WsSrc As Worksheet, WsDest As Worksheet
    Dim lngRow As Long
    Dim lngDateCutTo As Long
    Dim lngCount As Long

'   Set the variables
    Set WsSrc = Worksheets("ParticipantWS")    '<< give variables intuitive names e.g. WsSrc = Source worksheet
    Set WsDest = Worksheets("Archived Participants")   '<< you may need to change these to your actual sheet names
    
    'strRow = Range("Z21").Value
    lngDateCutTo = Range("Z25").Value
    lngRow = Range("Z24").Value
    
    lngRow = WsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1  '<< finds the last empty row in column A in the destination sheet
'   The Lrow (=Last row) is where you'll be copying the data to on the destination sheet
'   IF you wanted it pasted to the first available blank row - you'll pick row 10 instead

'   Set an Autofilter on the source sheet for Lilac and Syringa
'   Note the uuse of the asterisk wildcard - * - in case there are accidental spaces at the start or end of the names
    With WsSrc.Range("A1").CurrentRegion  '<< A With block needs and End With statement at the end
        .AutoFilter Field:=5, Criteria1:="NO" ', Operator:=xlAnd, Criteria2:=datCutTo
        .AutoFilter Field:=4, Criteria1:="<=" & lngDateCutTo
    '   Check to make sure there are actually some records selected - if not, stop code execution
        lngCount = WsSrc.Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count
        If WsSrc.Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then '<< test if only the header row is showing
            MsgBox "No records selected"                    '<< if so, tell the user
            .AutoFilter                                     '<< turn the autofilter off
            Exit Sub                                        '<< Exit the sub
        End If
'   Offset by 1 row to exclude the headers from the copy
        .Offset(1).Copy WsDest.Range(lngRow)         '<< copy the filtered value to the destination sheet - row 10
        .Offset(1).EntireRow.Delete                 '<< then delete those rows on the source sheet
        .AutoFilter                                 '<< turn the autofilter off
    End With

'WaSrc Range("A1:MY"2000).AdvancedFilter Action:=FilterCopy, CriterisRange:=(
'WsSrc.Range("A2:MY2000").SpecialCells(xlCellTypeVisible).Copy
'WsDest.Range(1, lngRow).PasteSpecial Paste:=xlPasteValues
'WsSrc.AutoFilterMode = False

End Sub

 

[NateSC]

I see one error and I have a few questions.

Error -

.Offset(1).Copy WsDest.Range(lngRow)

lngRow is not a complete range declaration. It needs a column as well.

.Offset(1).Copy WsDest.Range("A" & lngRow)

Questions/notes
This line isn't needed.

lngRow = Range("Z24").Value

This code:

lngCount = WsSrc.Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count
        If WsSrc.Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then

could be rewritten as:

lngCount = WsSrc.Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count
        If lngCount = 1 Then

The next thing would be to step through your code and see where it breaks or if it isn't filtering the correct data.

Good luck.

 

[Alex Blakenburg]

See if this helps:

Sub Macro5()

    Dim WsSrc As Worksheet, WsDest As Worksheet, WsTblOfContents As Worksheet
    Dim lngRow As Long
    Dim lngDateCutTo As Long

'   Set the variables
    Set WsSrc = Worksheets("ParticipantWS")    '<< give variables intuitive names e.g. WsSrc = Source worksheet
    Set WsDest = Worksheets("Archived Participants")   '<< you may need to change these to your actual sheet names
    Set WsTblOfContents = Worksheets("Table of Contents")          '<< could use ActiveSheet code initiated from this sheet
    
    lngDateCutTo = WsTblOfContents.Range("Z25").Value
    'lngRow = Range("Z24").Value
    
    lngRow = WsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1  '<< finds the last empty row in column A in the destination sheet

    With WsSrc.Range("A1").CurrentRegion  '<< A With block needs and End With statement at the end
        .AutoFilter Field:=5, Criteria1:="NO"
        .AutoFilter Field:=4, Criteria1:="<=" & lngDateCutTo
        
        If .SpecialCells(xlCellTypeVisible).Address = .Rows(1).Address Then '<< test if only the header row is showing
            MsgBox "No reords selected"                    '<< if so, tell the user
            .AutoFilter                                     '<< turn the autofilter off
            Exit Sub                                        '<< Exit the sub
        End If
'   Offset by 1 row to exclude the headers from the copy
        .Offset(1).Copy
            WsDest.Range("A" & lngRow).PasteSpecial Paste:=xlPasteValues       '<< copy the filtered value to the destination sheet - row 10
        .Offset(1).EntireRow.Delete                 '<< then delete those rows on the source sheet
        .AutoFilter                                 '<< turn the autofilter off
    End With

End Sub