Vba Comp from multiple worksheets based on cell Value

[Demer]

Hello, Sorry im not very good with VBA but I need a VBA to search through multiple worksheets and search column c for "Yes" based on c value copy adjacent data in column A from all worksheets and paste those values to a new sheet called "Archive" Note that I have over 40 sheets.

 

[My Aswer Is This]

Try this:

Sub Filter_Me_Please()
'Modified  10/24/2021  10:13:12 PM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim C As Long
Dim i As Long
C = 3 ' Column Number Modify this to your need
lastrow = Cells(Rows.Count, C).End(xlUp).Row
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Archive"

For i = 1 To Sheets.Count - 1
With Sheets(i).Cells(1, C).Resize(lastrow)
    .AutoFilter 1, "Yes"
    counter = .Columns(C).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
    lastrowa = Sheets("Archive").Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(, -2).Copy Sheets("Archive").Cells(lastrowa, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Next
Application.ScreenUpdating = True
End Sub

 

[Demer]

So the script does nothing?
Except create the new sheet?

Thats correct

So the script does nothing?
Except create the new sheet?

 

[My Aswer Is This]

So try my script in post 11

 

[My Aswer Is This]

I'm sorry. I test all my scripts so not sure why it's not working for you.

 

[Demer]

Try this:

Sub Filter_Me_Please()
'Modified  10/24/2021  10:13:12 PM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim C As Long
Dim i As Long
C = 3 ' Column Number Modify this to your need
lastrow = Cells(Rows.Count, C).End(xlUp).Row
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Archive"

For i = 1 To Sheets.Count - 1
With Sheets(i).Cells(1, C).Resize(lastrow)
    .AutoFilter 1, "Yes"
    counter = .Columns(C).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
    lastrowa = Sheets("Archive").Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(, -2).Copy Sheets("Archive").Cells(lastrowa, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Next
Application.ScreenUpdating = True
End Sub

Tried this one and it throws the same issue

Once I hit Debug it highlights

 

[My Aswer Is This]

Sorry. It works for me and has worked for others. Hopefully someone else here on the forum will be able to help you.

 

[Demer]

Tried this one and it throws the same issue
View attachment 49723

Once I hit Debug it highlights

View attachment 49724

I tried to apply the VBA to a new module and this time it gave me this error

 

[kevin9999]

So the script does nothing?
Except create the new sheet?

My Answer Is This - there doesn't look like there's anything wrong with your code, just wondering if the screenshot provided by the OP is 'typical' of ALL the sheets, specifically Sheet1? The screenshot looks like it might be sheet3?

 

[My Aswer Is This]

When you run the script are you running it from the first sheet in your workbook?

 

[My Aswer Is This]

My Answer Is This - there doesn't look like there's anything wrong with your code, just wondering if the screenshot provided by the OP is 'typical' of ALL the sheets, specifically Sheet1? The screenshot looks like it might be sheet3?

Thanks for your help. I use this same type script all the time so not sure why it's not working for user.