Multiple sheets feed into one sheet based on response

[manzier]

Hi,

I have a bit of a tough one here.

I have multiple spreadsheets (each with the same format). Here's an example of what one spreadsheet would look like

Answer	Number	Action	Date
Yes	1.1
No	1.2	This will be an action	5/30/15
No	1.3	Another action	6/5/15

<tbody>
</tbody>

Basically, every time you answer "No" you'll need to put in an action and a due date. I have about 20 sheets in this format. What I want to do is create another worksheet that will get all the "No" answers from each tab and put it in one sheet. Example:

1.2	This will be an action	5/30/15
1.3	Another action	6/5/15
2.1	Another action from another tab	6/5/15
3.4	and another one	7/1/15

<tbody>
</tbody>

What's the best way of going about this?

Thanks for the help!

 

[vcoolio]

Hello Manzier,

Perhaps the following code may do the job for you:-

Sub CopyData()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "Summary" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    For Each cell In Range("A2:A" & lRow)
        If cell.Value = "No" Then
            Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).Copy
            Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            'Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).ClearContents
        End If
    Next cell

NextSheet:
Next ws

Sheets("Summary").Columns.AutoFit
Sheets("Summary").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub

This line of code:-

'Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).ClearContents

has an apostrophe in front of it. If you want to clear the "used" data from the different sheets as you go then just remove the apostrophe and the transferred rows of data will be cleared. This will also prevent duplication in the Summary sheet.

Attached is my sample work book for you to peruse.

https://www.dropbox.com/s/ptd9mm81ufsw0as/Manzier(Multiple sheets to Summary).xlsm?dl=0

I hope that this helps.

Cherrio,
vcoolio.

 

[manzier]

Thank you! Will give this a shot

 

[manzier]

This is perfect vcoolio, thank you!

One question though: If I wanted to pick which columns I wanted to copy paste, as opposed to just taking the row, how would I write that into VBA? For example, if I wanted to copy paste only columns D, F, I, and J?

Thank you for your help.

 

[vcoolio]

Hello Manzier,

I slapped this together for you:-

Sub CopyData()
Dim ws As Worksheet
Dim lRow As Long

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "Summary" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    
    For Each cell In Range("A2:A" & lRow)
        If cell.Value = "No" Then
            Range(Cells(cell.Row, "D"), Cells(cell.Row, "D")).Copy
            Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Range(Cells(cell.Row, "F"), Cells(cell.Row, "F")).Copy
            Sheets("Summary").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Range(Cells(cell.Row, "I"), Cells(cell.Row, "J")).Copy
            Sheets("Summary").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            'Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).ClearContents
        End If
    Next cell

NextSheet:
Next ws

Sheets("Summary").Columns.AutoFit
Sheets("Summary").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub

https://www.dropbox.com/s/rgrtqu8nxc1n6if/Manzier(2).xlsm?dl=0

I hope its what you are wanting....................running late for work.....

Cheerio,
vcoolio.

 

[manzier]

You, sir, are amazing. Thank you vcoolio!