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

 

[bsquad]

there is no loop for the worksheets, and you are also declaring only one worksheet --> 1.1.2018.

NOTE: this code is assuming you have your "Sold Status" sheet at the very end, if you want it from the beginning change

For x = 1 To ThisWorkbook.Worksheets.Count - 1

to

For x = 2 To ThisWorkbook.Worksheets.Count

But try this out and let me know if you have issues

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


    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
                        ActiveSheet.Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo
                    End If
                Next
    Next x
Application.ScreenUpdating = True
End Sub

 

[Fluff]

Hi & welcome to MrExcel
How about 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
         Ws.Range("A1:P1").AutoFilter 16, "Sold"
         On Error Resume Next
         With Ws.Range("A2", Ws.Range("P" & Rows.Count).End(xlUp)).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]

This one worked! Thank you. It seems that it is still adding a blank line above the copied data though. Is there any way to remove that? Also, is it possible to bring over any conditional formatting that might have been done to the data before it was copied?

 

[ashleym81]

This one worked! Thank you. It seems that it is still adding a blank line above the copied data though. Is there any way to remove that? Also, is it possible to bring over any conditional formatting that might have been done to the data before it was copied?

there is no loop for the worksheets, and you are also declaring only one worksheet --> 1.1.2018.

NOTE: this code is assuming you have your "Sold Status" sheet at the very end, if you want it from the beginning change

For x = 1 To ThisWorkbook.Worksheets.Count - 1

to

For x = 2 To ThisWorkbook.Worksheets.Count

But try this out and let me know if you have issues

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


    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
                        ActiveSheet.Range("A:R").RemoveDuplicates Columns:=1, Header:=xlNo
                    End If
                Next
    Next x
Application.ScreenUpdating = True
End Sub

 

[bsquad]

I think that is in your

xCell.EntireRow.Copy Destination:=Worksheets("Sold Status").Range("A" & p [COLOR=#ff0000]+ 1[/COLOR])

Try removing the + 1

the 2nd p + 1 should take care of it so you are not overwriting


As far as my paygrade goes; you cannot use 'Copy Destination:=' function with Paste Special. You would have to do it in another line of code. If the cond formatting is the same for each, then you could just copy one row from one of tabs with the dates and PasteSpecial Paste:=xlPasteFormats etc to your ("Sold Status").UsedRange.Rows.Count

 

[ashleym81]

Removing it didn't work. That's ok though, it's functioning as I needed it to. I appreciate the help!

 

[Fluff]

@ashleym81
As a matter of interest, did you see the code I posted in post#3?

 

[bsquad]

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

 

[ashleym81]

Yes, I just tried it. I have a header on there and it copies the header as well. I changed the code to be from A2:T2 (that's how far my rows go), but now it just copies everything from all sheets and not just the rows that say "sold". I do like that the conditional formatting stays though. Any suggestions?