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]

This one is not working at all for me now. I run the macro and nothing happens.

I am not seeing where its copying a blank line after running it. I have your cond format paste included

Sub Spreadsheet()
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim p As Long
Dim x As Integer
Dim xER As Long


    For x = 1 To 1 'ThisWorkbook.Worksheets.Count - 1
        i = Worksheets(x).UsedRange.Rows.Count
        p = Worksheets("Sold Status").UsedRange.Rows.Count
            If p = 1 Then
                If Application.WorksheetFunction.CountA(Worksheets(x).UsedRange) = 0 Then p = 0
                End If
        Set xRg = Worksheets(x).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
                    End If
                Next
    Next x
    Worksheets("Sold Status").Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo
    With ThisWorkbook.Worksheets(1)
    xER = Worksheets("Sold Status").Range("A1").SpecialCells(xlCellTypeLastCell).Row
        For Each xCell In xRg
            If CStr(xCell.Value) = "Sold" Then
                xCell.EntireRow.Copy
                    With ThisWorkbook.Worksheets("Sold Status").Range("A2:R" & xER)
                        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End With
                    Exit For
            End If
        Next xCell
    End With
Application.ScreenUpdating = True
End Sub

 

[bsquad]

crap yea sorry, I for got to change some of the variables back

Sub Spreadsheet()
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim p As Long
Dim x As Integer
Dim xER As Long




    For x = 1 To ThisWorkbook.Worksheets.Count - 1
        i = Worksheets(x).UsedRange.Rows.Count
        p = Worksheets("Sold Status").UsedRange.Rows.Count
            If p = 1 Then
                If Application.WorksheetFunction.CountA(Worksheets(x).UsedRange) = 0 Then p = 0
                End If
        Set xRg = Worksheets(x).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
                    End If
                Next
    Next x
    Worksheets("Sold Status").Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo
    With ThisWorkbook.Worksheets(1)                                                                                  ' If your 'Sold Status' sheet is first, change this to 2
    xER = Worksheets("Sold Status").Range("A1").SpecialCells(xlCellTypeLastCell).Row
        For Each xCell In xRg
            If CStr(xCell.Value) = "Sold" Then
                xCell.EntireRow.Copy
                    With ThisWorkbook.Worksheets("Sold Status").Range("A2:R" & xER)
                        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End With
                    Exit For
            End If
        Next xCell
    End With
Application.ScreenUpdating = True
End Sub

 

[ashleym81]

I'm trying to see if I can play around with this and get it to work. That code does that same thing as the first code you posted. The formatting still does not come over. If it's not possible to do, then it's not that big of a deal.

crap yea sorry, I for got to change some of the variables back

Sub Spreadsheet()
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim p As Long
Dim x As Integer
Dim xER As Long




    For x = 1 To ThisWorkbook.Worksheets.Count - 1
        i = Worksheets(x).UsedRange.Rows.Count
        p = Worksheets("Sold Status").UsedRange.Rows.Count
            If p = 1 Then
                If Application.WorksheetFunction.CountA(Worksheets(x).UsedRange) = 0 Then p = 0
                End If
        Set xRg = Worksheets(x).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
                    End If
                Next
    Next x
    Worksheets("Sold Status").Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo
    With ThisWorkbook.Worksheets(1)                                                                                  ' If your 'Sold Status' sheet is first, change this to 2
    xER = Worksheets("Sold Status").Range("A1").SpecialCells(xlCellTypeLastCell).Row
        For Each xCell In xRg
            If CStr(xCell.Value) = "Sold" Then
                xCell.EntireRow.Copy
                    With ThisWorkbook.Worksheets("Sold Status").Range("A2:R" & xER)
                        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End With
                    Exit For
            End If
        Next xCell
    End With
Application.ScreenUpdating = True
End Sub

 

[Fluff]

If your header row is row 2 try

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
         Ws.Range("A2:T2").AutoFilter 16, "Sold"
         On Error Resume Next
         With Ws.Range("A3: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
   Next Ws
   
End Sub

 

[ashleym81]

So that actually worked perfectly. It brought over all of the conditional formatting.

I added ActiveSheet.Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo so that it didn't keep copying the same data.

The only issue is that it gives a pop up box with an error 400. After clicking ok, it runs just fine. Is there any way to adjust to where that box doesn't come up?

If your header row is row 2 try

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
         Ws.Range("A2:T2").AutoFilter 16, "Sold"
         On Error Resume Next
         With Ws.Range("A3: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
   Next Ws
   
End Sub

 

[Fluff]

Do you have any hidden sheets, or protected sheets?
If not step through the code line by line using F8 & let me know what line is highlighted when it crashes.

 

[ashleym81]

I haven't seen any errors when I step through it. I do have hidden sheets though. So I have a tab for every month next year, but I will only be displaying the current month and hiding them when the month is over.

Do you have any hidden sheets, or protected sheets?
If not step through the code line by line using F8 & let me know what line is highlighted when it crashes.

 

[Fluff]

Do you still get that error if you remove the line that you added?

 

[ashleym81]

Yes. So I stepped into the code again. I can run through it three times before I get an error.

I am getting 'Run-time error '1004'' Application-defined or object-defined error. This happens right after the Ws.Range("A2:T2").AutoFilter 16, "Sold" line.

I unhid all of my worksheets as well and that didn't make a difference. Now, when I try to work off another tab, it is copying the header of another page. It does not do that when I work off of the original tab. For example, 1.1.2018 tab vs 2.1.2018.

Do you still get that error if you remove the line that you added?

 

[Fluff]

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