Copy paste rows of all worksheets depending on the color of a cell

[jopezzo]

Dear All,

I am a beginner in VBA and I would need some help.

I am trying to write a code to copy all rows for which the cell in column A is in yellow, do this in all worksheets and paste these rows one after the other in a sheet called "PastedRows".

This sheet "PastedRows" is deleted at the beginning of the code and re-created every time the code is run.

I have found some code and tried to adapt it. The issue I am facing is with the loop. Everytime the loop is changing sheet, the variable lNewRow is reset, which is not what I want.

In other words, I would like to have the pasted rows of each sheet being pasted below the last rows already pasted in "PastedRows". Currently the code is overwriting the first rows every time the code changed worksheet.

Here is the code:


Option Explicit


Sub loop_through_all_worksheets()


Dim ws As Worksheet
Dim starting_ws As Worksheet
Dim wks As Worksheet
Dim wNew As Worksheet
Dim lRow As Long
Dim lNewRow As Long
Dim x As Long


'Delete sheet PastedRows
Sheets("PastedRows").Delete


'Create sheet Pasted Rows
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "PastedRows"


'Set active sheet
Set starting_ws = ActiveSheet


'Loop to copy paste all rows in yellow and paste them in sheet "PastedRows"
For Each ws In ThisWorkbook.Worksheets
ws.Activate

Set wks = ActiveSheet
lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wNew = Worksheets("PastedRows")
lNewRow = 1
For x = 1 To lRow
If wks.Cells(x, 1).Interior.Color = vbYellow Then
wks.Cells(x, 1).EntireRow.Copy wNew.Cells(lNewRow, 1)
lNewRow = lNewRow + 1
End If
Next

Next


'Activate the worksheet that was originally active
starting_ws.Activate


End Sub

 

[BarryL]

Hi, welcome to the forum. That lNewRow isn't really needed. Also you can you the ws to reference the current sheet in the loop rather than adding in a second worksheet object (wks). I've left the activates in but these could also be removed

Sub loop_through_all_worksheets()




Dim ws As Worksheet
Dim starting_ws As Worksheet
Dim wks As Worksheet
Dim wNew As Worksheet
Dim lRow As Long
Dim lNewRow As Long
Dim x As Long




'Delete sheet PastedRows
Sheets("PastedRows").Delete




'Create sheet Pasted Rows
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "PastedRows"
Set wNew = Worksheets("PastedRows")


'Set active sheet
Set starting_ws = ActiveSheet




'Loop to copy paste all rows in yellow and paste them in sheet "PastedRows"
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "PastedRows" Then GoTo nextws
ws.Activate


lRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row




For x = 1 To lRow
If ws.Cells(x, 1).Interior.Color = vbYellow Then
ws.Cells(x, 1).EntireRow.Copy wNew.Cells(wNew.Range("A" & Rows.Count).End(xlUp).Row + 1, 1)


End If
Next
nextws:
Next




'Activate the worksheet that was originally active
starting_ws.Activate




End Sub

 

[BarryL]

Forgot to say that I added in that when the ws object gets to the PastedRows sheet, it will skip this sheet. Otherwise you would be duplicating data.

Also, is there any benefit to deleting PastedRows then recreating PastedRows? why not just clear the PastedRows content? Is that an option?

 

[vcoolio]

Hello Jopezzo,

Based on what BarryL says above, you could trim the code right down to something like this:-

Sub Test()

Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("PastedRows")

Application.ScreenUpdating = False

sh.UsedRange.Offset(1).Clear  'Clears main sheet prior to new data transfer.

For Each ws In Worksheets
         If ws.Name <> "PastedRows" Then
With ws.[A1].CurrentRegion
        .AutoFilter 1, vbYellow, 8  '----> Enumeration for xlFilterCellColor
        .Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
        .AutoFilter
        End With
    End If
Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

The code assumes that there are headings in row1 of each sheet.
No need to delete/re-create the main sheet. The code clears the main sheet (except for headings) on each transfer of data.

Test the code in a copy of your workbook first.

I hope that this helps.

Cheerio,
vcoolio.

 

[jopezzo]

Thanks BarryL and vcoolio! That is exactly what I was looking for. I was not exactly close to your result.

I will need some time to understand your code, but at least it works perfectly!

 

[vcoolio]

You're welcome Jopezzo. I'm glad that we've been able to help.

Below is the code again from post #4 with some comments that may help you understand it a little more.

Sub Test()

Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("PastedRows")

Application.ScreenUpdating = False 'Turns off the screen updating procedure whilst the code runs. Stops screen flickering.

sh.UsedRange.Offset(1).Clear  'Clears main sheet, except headings, prior to new data transfer.

For Each ws In Worksheets  '---->Refers to each sheet in the workbook.
         If ws.Name <> "PastedRows" Then  'This excludes the main sheet from the copy/paste process.
With ws.[A1].CurrentRegion  '---->The data set starting at Cell(1,1) or A1
        .AutoFilter 1, vbYellow, 8  'Filters Column A(1) for the yellow colour. 8 is the enumeration for xlFilterCellColor
        .Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2) 'Copy/paste process for all the filtered data starting from row2 (offset(1): one row down from the headings).
        .AutoFilter  '---->Turns off the autofilter.
        End With  '---->Closes off the 'with' statement.
    End If  '---->Closes off the 'If' statement.
Next ws  '---->Loops to the next worksheet.

Application.CutCopyMode = False  'Prevents the 'marching ants' from appearing around the filtered/copied data
Application.ScreenUpdating = True  'Screen updating is allowed to continue.

End Sub

Cheerio,
vcoolio.

 

[jopezzo]

I ran the code on my usual file and now I'm getting an error message saying "there isn't enough memory to complete this action".

I tried to use the "clean excess formatting" button, decreased the number of rows, reduced the source of the pivot to what is really needed. The file is now 9Mb instead of 30Mb.

However, I still get this error message.

Any idea?

 

[vcoolio]

Hello Jopezzo,

Overuse of formatting, including conditional formatting and using large amounts of formulae (especially array formulae) contribute greatly to this problem. Then again, it could be just not enough RAM on your machine but its never easy to determine the exact cause.

This MS article may help:-

https://support.microsoft.com/en-au...an-excel-workbook-so-that-it-uses-less-memory

As a test, try creating a copy of your workbook, strip it of all forms of formatting (inc. conditional formatting) other than the yellow colouring of the relevant cells in Column A and see how that works.

Cheerio,
vcoolio.