Macro to copy rows from multiple worksheets into one worksheet if criteria is met

[bmac206]

I have a spreadsheet that has over a dozen worksheets. Each worksheet has the same format with column headers from A1:G1 and then data underneath. Each worksheet has a varying number of rows with data. Column G is a dropdown box of either "Yes" or "No". I want to create a macro that will copy all the rows on each worksheet only if Column G is equal to "Yes" and combine them on a sheet I am calling "Master". This Master sheet will have the same column headers from A1:G1.

I would also need the macro to delete what it had previously pasted in the Master sheet (everything below A1:G1)

Much appreciated if anyone can help. Thanks!

 

[JoeMo]

I have a spreadsheet that has over a dozen worksheets. Each worksheet has the same format with column headers from A1:G1 and then data underneath. Each worksheet has a varying number of rows with data. Column G is a dropdown box of either "Yes" or "No". I want to create a macro that will copy all the rows on each worksheet only if Column G is equal to "Yes" and combine them on a sheet I am calling "Master". This Master sheet will have the same column headers from A1:G1.

I would also need the macro to delete what it had previously pasted in the Master sheet (everything below A1:G1)

Much appreciated if anyone can help. Thanks!

This assumes that your master sheet is the left-most sheet tab in the workbook (sheet(1)).

Sub bmac206()
Dim nR As Long, R As Range
'The Master sheet must be the first sheet in the workbook
With Sheets(1).Range("A1").CurrentRegion.Offset(1, 0)
    .ClearContents
End With
Application.CutCopyMode = False
For i = 2 To Sheets.Count
    With Sheets(i).Range("A1").CurrentRegion
        .AutoFilter field:=Columns("G").Column, Criteria1:="yes"
        On Error Resume Next
        Set R = .SpecialCells(xlCellTypeVisible)
        If Not R Is Nothing Then
            R.Offset(1, 0).Copy
            With Sheets(1)
                nR = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & nR).PasteSpecial Paste:=xlValues
                Application.CutCopyMode = False
            End With
        End If
        .AutoFilter
    End With
Next i
End Sub

 

[bmac206]

Thanks! It seems to be almost working but some of the rows that say "Yes" are not getting copied. Specifically, if a row has a "No" then the very next row (whether column G has a "Yes" or a "No") it will not get copied to the master. Any ideas?

 

[JoeMo]

Thanks! It seems to be almost working but some of the rows that say "Yes" are not getting copied. Specifically, if a row has a "No" then the very next row (whether column G has a "Yes" or a "No") it will not get copied to the master. Any ideas?

I don't understand the bold part in the quote. If the next row is a "no" you don't want it copied do you?

If it's just missing some "yes" rows you might want to verify that the "yes" in the row has no spaces before or after it. You can do this in various ways. For now, suppose G5 has "yes" and didn't get copied, then in an empty cell enter =LEN(G5) and see what number is returned. If its not 3 then there are extra characters (probably spaces) in that cell and Excel will not see the cell as having "yes" in it.

If that's not the problem, then you can step through the code and see how the filter is being applied to try to diagnose what's happening. I tested the code and found no issues.

 

[Michael M]

Try

Sub MM1()
Dim r As Long, lr As Long, lr2 As Long, ws As Worksheet
lr = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Master").Range("A2:G" & lr).ClearContents
For Each ws In Worksheets
    If ws.Name <> "Master" Then ws.Activate
    lr2 = Cells(Rows.Count, "A").End(xlUp).Row
        For r = 2 To lr2
            If Range("G" & r).Value = "Yes" Then
                Rows(r).Copy Destination:=Sheets("Master").Range("A" & lr + 1)
                lr = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
            End If
        Next r
Next ws
End Sub

 

[hiker95]

bmac206,

Welcome to the MrExcel forum.


Sample worksheets:

Excel Workbook
	A	B	C	D	E	F	G
1	A	B	C	D	E	F	G
2
3
4
5
6
7
8
9
10
11
Master

Excel Workbook
	A	B	C	D	E	F	G
1	A	B	C	D	E	F	G
2
3	Sheet1	B3	C3	D3	E3	F3	Yes
4
5	Sheet1	B5	C5	D5	E5	F5	Yes
6
7	Sheet1	B7	C7	D7	E7	F7	Yes
8
Sheet1

Excel Workbook
	A	B	C	D	E	F	G
1	A	B	C	D	E	F	G
2
3
4	Sheet2	B4	C4	D4	E4	F4	Yes
5
6	Sheet2	B6	C6	D6	E6	F6	Yes
7
8	Sheet2	B8	C8	D8	E8	F8	Yes
9
Sheet2

Excel Workbook
	A	B	C	D	E	F	G
1	A	B	C	D	E	F	G
2
3
4
5
6
7
8
9
10	Sheet4	B10	C10	D10	E10	F10	Yes
11
12	Sheet4	B12	C12	D12	E12	F12	Yes
13
14	Sheet4	B14	C14	D14	E14	F14	Yes
15
Sheet4

After the macro (which took 0.125 seconds to run on my Lenovo T61 laptop computer):

Excel Workbook
	A	B	C	D	E	F	G
1	A	B	C	D	E	F	G
2	Sheet1	B3	C3	D3	E3	F3	Yes
3	Sheet1	B5	C5	D5	E5	F5	Yes
4	Sheet1	B7	C7	D7	E7	F7	Yes
5	Sheet2	B4	C4	D4	E4	F4	Yes
6	Sheet2	B6	C6	D6	E6	F6	Yes
7	Sheet2	B8	C8	D8	E8	F8	Yes
8	Sheet4	B10	C10	D10	E10	F10	Yes
9	Sheet4	B12	C12	D12	E12	F12	Yes
10	Sheet4	B14	C14	D14	E14	F14	Yes
11
Master

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub GetYes()
' hiker95, 12/13/2012
' http://www.mrexcel.com/forum/excel-questions/674560-macro-copy-rows-multiple-worksheets-into-one-worksheet-if-criteria-met.html
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Sheets("Master")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 1 Then wM.Range("A2:G" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
  If ws.Name <> "Master" Then
    y = 0
    On Error Resume Next
    y = Application.CountIf(ws.Columns(7), "Yes")
    On Error GoTo 0
    If y > 1 Then
      firstaddress = ""
      With ws.Columns(7)
        Set c = .Find("Yes", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            nr = wM.Range("G" & Rows.Count).End(xlUp).Offset(1).Row
            ws.Range("A" & c.Row & ":G" & c.Row).Copy wM.Range("A" & nr)
            Application.CutCopyMode = False
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      End With
    End If
  End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the GetYes macro.

 

[mirabeau]

I have a spreadsheet that has over a dozen worksheets. Each worksheet has the same format with column headers from A1:G1 and then data underneath. Each worksheet has a varying number of rows with data. Column G is a dropdown box of either "Yes" or "No". I want to create a macro that will copy all the rows on each worksheet only if Column G is equal to "Yes" and combine them on a sheet I am calling "Master". This Master sheet will have the same column headers from A1:G1.

I would also need the macro to delete what it had previously pasted in the Master sheet (everything below A1:G1)

Much appreciated if anyone can help. Thanks!

Same post also made here
Macro to copy rows from multiple worksheets into one worksheet if criteria is met
where an answer is given.

 

[Michael M]

Grrr....I hate that...

 

[bmac206]

I was using a drop down box so the "Yes" and "No" were the same. I tested several times with no luck. Thanks.

 

[bmac206]

Micheal - The macro you wrote seemed to be working for the most part but when i would run the report a second time, the new data would paste below where the old data was on the Master (even though the cell contents were deleted). Thanks for the help though.