Copy rows with specific text from multiple Worksheets to another worksheet

[craigy111]

HI guys.

I would like to copy rows from multiple worksheets (Jan to Dec) that contain certain text - WON, PENDING, LOST - When a VBA Button is pressed on another Worksheet the information is copied to VIEW. So far i can copy from only one worksheet at a time.

CODE so far

Sub CopyWONtoView()

Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet

Set Source = ActiveWorkbook.Worksheets("Jan")
Set Target = ActiveWorkbook.Worksheets("VIEW")

Target.Range("$A$4:$R$50").Clear

j = 4 ' Start copying to row 4 in target sheet
For Each c In Source.Range("A4:A95")
If c = "WON" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c

Worksheets("VIEW").Activate

End Sub

Any and all help would be much appreciated.

 

[Fluff]

Do you just have 13 sheets (ie Jan to Dec & View)?
Also do you have anything on the View sheets that needs to be kept, or can we wipe the sheet completely?

 

[craigy111]

Yeah there is a 13th sheet called View. And view can be refreshed every time the VBA is run.

 

[Fluff]

I forgot to ask if you have header rows, so this code assumes that row 3 is a header row.
If that's wrong let me know

Sub CopyDatatoView()

    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim DstSht As Worksheet
    
    Set DstSht = ActiveWorkbook.Worksheets("VIEW")
    
    DstSht.Rows("4:" & Rows.Count).Clear
    
    For Each Ws In Worksheets
        If Not Ws.Name = "View" Then
            UsdRws = Ws.Range("A" & Rows.Count).End(xlUp).Row
            Ws.Range("A3").AutoFilter
            Ws.Range("A3:A" & UsdRws).AutoFilter Field:=1, Criteria1:="=chr20" _
                , Operator:=xlOr, Criteria2:="=chrX"
            On Error Resume Next
            Ws.Range("A4:A" & UsdRws).SpecialCells(xlVisible).EntireRow.Copy _
                DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            Ws.Range("A3:A" & UsdRws).AutoFilter Field:=1, Criteria1:="=chr19"
            Ws.Range("A4:A" & UsdRws).SpecialCells(xlVisible).EntireRow.Copy _
                DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            On Error GoTo 0
            Ws.Range("a4").AutoFilter
        End If
    Next Ws
    
    DstSht.Activate

End Sub

 

[craigy111]

Thanks for the quick response but i don't think my explanation was great.

I have 3 vba buttons "WON" "PENDING" "LOST" If for example WON is pressed
all WON rows in all WORKSHEETS would be copied to VIEW. Then if one of the
others are selected the screen clears all other info and pastes the other selection.

My header rows are on Line 5 in the Month Sheets but in View The header row is row 3.

I apologize for the rubbish explanation at the start.

 

[Fluff]

Ok, try this, changing the part in red

Sub CopyDatatoView()

    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim DstSht As Worksheet
    
    Set DstSht = ActiveWorkbook.Worksheets("VIEW")
    
    DstSht.Rows("4:" & Rows.Count).Clear
    
    For Each Ws In Worksheets
        If Not Ws.Name = "View" Then
            UsdRws = Ws.Range("A" & Rows.Count).End(xlUp).Row
            Ws.Range("A5").AutoFilter
            Ws.Range("A5:A" & UsdRws).AutoFilter Field:=1, Criteria1:="=[COLOR=#ff0000]WON[/COLOR]"
            On Error Resume Next
            Ws.Range("A6:A" & UsdRws).SpecialCells(xlVisible).EntireRow.Copy _
                DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            On Error GoTo 0
            Ws.Range("A5").AutoFilter
        End If
    Next Ws
    
    DstSht.Activate

End Sub

 

[craigy111]

Sorry for the delay in getting back.

This looks like it would work but unfortunately it try's to paste everything above the header line first then stops.

Above the header line on the month sheets there are calculations and and merged cells, i have tried to modify
your code but with no success as i am pretty new to vba coding.

 

[Fluff]

Try running this. It will come up with a message box, saying what the start row is.
What is the value

Sub CopyDatatoView()

    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim DstSht As Worksheet
    
    Set DstSht = ActiveWorkbook.Worksheets("VIEW")
    
    DstSht.Rows("4:" & Rows.Count).Clear
    [COLOR=#ff0000]MsgBox "Start row is " & DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    Exit Sub[/COLOR]
    For Each Ws In Worksheets
        If Not Ws.Name = "View" Then
            UsdRws = Ws.Range("A" & Rows.Count).End(xlUp).Row
            Ws.Range("A5").AutoFilter
            Ws.Range("A5:A" & UsdRws).AutoFilter Field:=1, Criteria1:="=chr20"
            On Error Resume Next
            Ws.Range("A6:A" & UsdRws).SpecialCells(xlVisible).EntireRow.Copy _
                DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            On Error GoTo 0
            Ws.Range("A5").AutoFilter
        End If
    Next Ws
    
    DstSht.Activate

End Sub

Once you click OK on the message box the macro will quit.

 

[craigy111]

Hi i have worked out one of the issues which was i had forgotten to take into account the hidden
WorkSheets, now that i have accounted for them it still not working correct.

For some reason it is only looking at the first 4 rows in column A.

Here is what i have so far:

Sub CopyDatatoView()

Dim UsdRws As Long
Dim Ws As Worksheet
Dim DstSht As Worksheet

Set DstSht = ActiveWorkbook.Worksheets("VIEW")

DstSht.Rows("5:" & Rows.Count).Clear

For Each Ws In Worksheets
If Not Ws.Name = "VIEW" Or Ws.Name = "REVIEW" Or Ws.Name = "LIST" Or Ws.Name = "DATA" Then

UsdRws = Ws.Range("A" & Rows.Count).End(xlUp).Row

Ws.Range("A5").AutoFilter
Ws.Range("A5:A$" & UsdRws).AutoFilter Field:=1, Criteria1:="=WON"
On Error Resume Next
Ws.Range("A6:A" & UsdRws).SpecialCells(xlVisible).EntireRow.Copy _
DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
On Error GoTo 0
Ws.Range("A5").AutoFilter
End If
Next Ws

DstSht.Activate

End Sub

Thanks for the help so far any other ideas?

Cheers

 

[Fluff]

Try this

Sub CopyDatatoView()

    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim DstSht As Worksheet
    
    Set DstSht = ActiveWorkbook.Worksheets("VIEW")
    
    DstSht.Rows("4:" & Rows.Count).Clear
    
    For Each Ws In Worksheets
        If Ws.Name <> "View" And Ws.Name <> "REVIEW" And Ws.Name <> "LIST" And Ws.Name <> "DATA" Then
            UsdRws = Ws.Range("A" & Rows.Count).End(xlUp).Row
            Ws.Range("A5").AutoFilter
            Ws.Range("A5:A" & UsdRws).AutoFilter Field:=1, Criteria1:="=chr20"
            On Error Resume Next
            Ws.Range("A6:A" & UsdRws + 1).SpecialCells(xlVisible).EntireRow.Copy _
                DstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            On Error GoTo 0
            Ws.Range("A5").AutoFilter
        End If
    Next Ws
    
    DstSht.Activate

End Sub