VBA Script to automatically copy & paste data from multiple worksheets to a master sheet

[steve2115]

Looking for a vba script to automatically copy & paste data from multiple worksheets to a master sheet named Returns. The data that I need to copy resides in columns A through N on multiples sheets. These sheet names are Jan, Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec. However I do not want to copy the header row for each so Row1 on each of these sheets should be excluded. Also, I want to exclude all row data that has "GR for acc.assgt rev"
in column C of all sheets.


Any help would be appreciated.

Thanks in Advance

 

[brian.wethington]

Perhaps something like this might work out for you. YOu did not state which column might contain the "GR for acc.assgt rev" entry, but I assumed that it might be column A using this code. I moved everything over to the Returns Sheet and then used an autofilter feature to remove those entries. I further assumed that all sheets were in the active workbook and any sheet not named returns would be a month's entries. Taking all those assumptions into account perhaps you can determine how to adjust the code for your needs if the assumptions are not accurate:

Sub DetailConsolidation()
Dim WS As Worksheet, WS1 As Worksheet, WB As Workbook

Set WS1 = ActiveWorkbook.Worksheets("Return")
For Each WS In ActiveWorkbook.Worksheets
    If WS.Name <> WS1.Name Then
        WS.Range("A2:N" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Copy WS1.Cells(Rows.Count, 1).End(xlUp).Offset(1)
    End If
Next
If WorksheetFunction.CountIf(WS1.Range("A:A"), "GR for acc.assgt rev") > 0 Then
    WS1.Range("A2").AutoFilter Field:=1, Criteria1:="GR for acc.assgt rev"
    WS1.Range("A2", WS1.Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    WS1.Range("A2").AutoFilter
End If

End Sub

 

[steve2115]

Thanks Brian. I just tested. This almost has it, however I do have other sheets in the workbook that I do not want top copy the data from. How would I alter the code to only grab the Jan through Dec worksheets?

To clarify a bit more the "GR for acc.assgt rev" is in column C on worksheets Jan through Dec.

Thanks again, I would have never got this far without the help.

 

[brian.wethington]

Out of curiosity, how are your sheets set up in your workbook and will that change? Meaning is Jan always located at the first of the Workbook or 2nd, so on and so forth?

 

[steve2115]

Yes it's possible that they could change as I have multiple people who will be using and they may move them on occasion.

 

[brian.wethington]

Well then perhaps something like this with an array of the sheet names:

End Sub
Sub DetailConsolidation()
Dim WS As Worksheet, WS1 As Worksheet, WB As Workbook
Dim MyArray

MyArray = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Set WS1 = ActiveWorkbook.Worksheets("Return")
For x = 0 To 11
    Set WS = ActiveWorkbook.Worksheets(MyArray(x))
    WS.Range("A2:N" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Copy WS1.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next
If WorksheetFunction.CountIf(WS1.Range("C:C"), "GR for acc.assgt rev") > 0 Then
    WS1.Range("A2", WS1.Cells(Rows.Count, "n").End(xlUp)).AutoFilter Field:=3, Criteria1:="GR for acc.assgt rev"
    WS1.Range("A2", WS1.Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    WS1.Range("A2").AutoFilter
End If

End Sub

 

[steve2115]

One issue I came across. Code is copy blank rows from the Jan-Dec sheets and pasting them onto Return. Is there a way not to copy blank rows on Jan-Dec sheets? I also noticed that code is not pasting row A2 from Jan-Dec sheets.

 

[brian.wethington]

WS.Range("A2:N" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Copy

This copies A2 to the last row of the column and uses column N. Thus, it is copying row 2.
It may be removing it if C is showing your stipulated entry of "GR for acc.assgt rev" but that is only case I can get the code to not copy the 2nd row for me.

as for not copying blank rows, if the cell in column A of a row is empty then is the entire row empty?

I will run a few more tests later tonight to make sure code is running as I would expect, but it will have to be much later on my end.

 

[steve2115]

The part of the code for A2:N seems correct to me as well but for some reason it's not pasting it to Return sheet. I verified that Jan-Dec sheets do not have "GR for acc.assgt rev" in column C for that row.

as for not copying blank rows, if the cell in column A of a row is empty then is the entire row empty?

Yes the entire row is blank if cell A2 is blank

 

[brian.wethington]

So this will take care of your issues with the blank rows:

Sub DetailConsolidation()
Dim WS As Worksheet, WS1 As Worksheet, WB As Workbook
Dim MyArray, x As Long

MyArray = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Set WS1 = ActiveWorkbook.Worksheets("Return")
For x = 0 To 11
    Set WS = ActiveWorkbook.Worksheets(MyArray(x))
    WS.Range("A2:N" & WS.Cells(Rows.Count, 1).End(xlUp).row).Copy WS1.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next
If WorksheetFunction.CountIf(WS1.Range("C:C"), "GR for acc.assgt rev") > 0 Then
    WS1.Range("A2", WS1.Cells(Rows.Count, "n").End(xlUp)).AutoFilter Field:=3, Criteria1:="GR for acc.assgt rev"
    WS1.Range("A2", WS1.Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    WS1.Range("A2").AutoFilter
End If
If WorksheetFunction.CountBlank(WS1.Range("A1", WS1.Cells(Rows.Count, 1).End(xlUp))) > 0 Then
    WS1.Range("A1", WS1.Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If

End Sub

No matter what I have tried to this point, I have not been able to replicate your issue of not copying row 2 yet. Is there anything special about row 2 in your particular data model?