Copy rows from multiple worksheets based on criteria

[ashleym81]

Hi,

I am having a little trouble with my VBA code for my workbook and hoping someone can help.

So I need the code to copy an entire line and paste it to another worksheet without cutting it from the original sheet. The criteria it is based on is in Column P and will be labelled as "Sold". The worksheet everything needs to be copied to is called Sold Status. I have each worksheet labelled for the month of the year, so 1.1.2018, 2.1.2018, 3.1.2018, etc. So far, I have only been able to get it to pull from one sheet at a time. It would be great if it could search through all of the worksheets for that criteria and copy it to the Sold Status sheet.

I was having an issue where it was copying the same data over and over, so I added in the RemoveDuplicates and that seemed to fix it. However, it is no longer copying over the conditional formatting, when it was before I added that line.

Any help is greatly appreciated!

Here is my code:

Sub Spreadsheet()
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim j As Long
i = Worksheets("1.1.2018").UsedRange.Rows.Count
p = Worksheets("Sold Status").UsedRange.Rows.Count
If p = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("1.1.2018").UsedRange) = 0 Then p = 0
End If
Set xRg = Worksheets("1.1.2018").Range("P2:P" & i)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "Sold" Then
xCell.EntireRow.Copy Destination:=Worksheets("Sold Status").Range("A" & p + 1)
p = p + 1
ActiveSheet.Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo
End If
Next
Application.ScreenUpdating = True
End Sub

 

[ashleym81]

I actually have the headers in row 1 for all tabs. All worksheets are the same, just named differently. So I'm a little confused as to why it's pulling one header from one page, but not any of the others.

That sounds like your header row isn't always in row 2. Is that correct?

 

[Fluff]

It may be that you don't have anything with "sold" in col 16.
Try this

Sub Spreadsheet()
   
   Dim Ws As Worksheet
   Dim SldSht As Worksheet
 
Application.ScreenUpdating = False
 
   Set SldSht = Sheets("Sold Status")
   For Each Ws In Worksheets
      If Not Ws.name = "Sold Status" Then
         If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
         If WorksheetFunction.CountIf(Ws.Columns(16), "Sold") > 0 Then
            Ws.Range("A1:T1").AutoFilter 16, "Sold"
            On Error Resume Next
            With Ws.Range("A2:T" & Ws.Range("P" & Rows.Count).End(xlUp).row).SpecialCells(xlVisible)
               .copy SldSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            End With
            On Error GoTo 0
            Ws.AutoFilterMode = False
         End If
      End If
   Next Ws
   
End Sub

 

[ashleym81]

This one works perfectly. It copies over the formatting and I no longer get the errors. Thank you so much for the help! I really appreciate it.

It may be that you don't have anything with "sold" in col 16.
Try this

Sub Spreadsheet()
   
   Dim Ws As Worksheet
   Dim SldSht As Worksheet
 
Application.ScreenUpdating = False
 
   Set SldSht = Sheets("Sold Status")
   For Each Ws In Worksheets
      If Not Ws.name = "Sold Status" Then
         If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
         If WorksheetFunction.CountIf(Ws.Columns(16), "Sold") > 0 Then
            Ws.Range("A1:T1").AutoFilter 16, "Sold"
            On Error Resume Next
            With Ws.Range("A2:T" & Ws.Range("P" & Rows.Count).End(xlUp).row).SpecialCells(xlVisible)
               .copy SldSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            End With
            On Error GoTo 0
            Ws.AutoFilterMode = False
         End If
      End If
   Next Ws
   
End Sub

 

[Fluff]

Glad we could help & thanks for the feedback