Pulling Multiple Worksheets into Summary Sheet - VBA

gped123

New Member
Joined
Aug 21, 2017
Messages
15
Hi All,

I’m really hoping for some help as I’ve been trying to do something on Excel for a few days now and it’s driving me mad – my VBA skills are limited at best so any help would be hugely appreciated.

I’m looking to build a macro that allows me to pull rows of information from multiple worksheets into a summary worksheet after searching for a certain criteria (i.e. Action Owner).

So for example, if the Action Owner is ‘John Smith’ then I would like to be able to search for ‘John Smith’ in the summary sheet and then all information relating to ‘John Smith’ will automatically be pasted into the summary worksheet, but under separate headings of ‘Sheet 1’, ‘Sheet 2’, ‘Sheet 3’ and ‘Sheet 4’ so that I can differentiate between the data as each sheet refers to a different meeting.

Within the spreadsheet, I have five worksheets all with the same headings of which I’ve listed below.

Sheet 1
Column B4: Reference
Column C4: Description
Column D4: ExCo Owner
Column E4: Action Owner
Column F4: Due Date
Column G4: Complete?
Column H4: Comments

Sheet 2
Column B4: Reference
Column C4: Description
Column D4: ExCo Owner
Column E4: Action Owner
Column F4: Due Date
Column G4: Complete?
Column H4: Comments

Sheet 3
Column B4: Reference
Column C4: Description
Column D4: ExCo Owner
Column E4: Action Owner
Column F4: Due Date
Column G4: Complete?
Column H4: Comments

Sheet 4
Column B4: Reference
Column C4: Description
Column D4: ExCo Owner
Column E4: Action Owner
Column F4: Due Date
Column G4: Complete?
Column H4: Comments

Sheet 5
Column B4: Reference
Column C4: Description
Column D4: ExCo Owner
Column E4: Action Owner
Column F4: Due Date
Column G4: Complete?
Column H4: Comments

So to confirm, columns B – H should all be pulled into the summary sheet, but the data should only be pulled if the search matches a set criteria (i.e. the name of an action owner).

Happy to provide more information on this but I would be ever so grateful for any help that you could provide on this.

Anything anyone can do to help would be greatly appreciated. Thank you in advance for your help!
 
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

Yes I can see that now. Thanks for reposting. Let me see what I can do for you.
 
Upvote 0

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

Okay, give this modified code a try. I think I have the formatting set now to match your screenshot and resolved where it may at times start writing at Row 3.

Let me know what you think.

Frank

Code:
Option Explicit
Sub FilterCopyToSummary()


Dim cfws As Worksheet  ' Copy from Worksheet
Dim ctws As Worksheet  ' Copy to Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long       ' Copy from WS lastrow
Dim ctlr As Long       ' Copy to WS lastrow
Dim startrow As Long   ' First Row for Border
Dim i As Integer
Dim x As Integer
Dim selname As String


'   Copy data from Sheet1-Sheet5 and Paste in Summary Worksheet
'   Define Copy To Worksheet and Clear existing data
Set ctws = Worksheets("Summary")
ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row
If ctlr > 5 Then
    With ctws
        .Range(.Cells(6, 1), .Cells(ctlr, 8)).Clear
    End With
End If
ctlr = 8
selname = ctws.Range("C5").Value
With Range("B2")
    .Value = "Summary of Actions - " & selname
    .Font.Color = RGB(0, 176, 240)
    .Font.Size = 16
End With
With ctws.Range("C5")
    .Borders.LineStyle = xlContinuous
End With


For i = 1 To 5
    If ctlr <= 5 Then
        ctlr = 8
    End If
    Select Case i
        Case 1
            Set cfws = Worksheets("Sheet1")
        Case 2
            Set cfws = Worksheets("Sheet2")
        Case 3
            Set cfws = Worksheets("Sheet3")
        Case 4
            Set cfws = Worksheets("Sheet4")
        Case 5
            Set cfws = Worksheets("Sheet5")
    End Select
    
'   Clear any existing Filters on the Copy From Worksheet and determine last row of data
    On Error Resume Next
    cfws.AutoFilterMode = False
    cflr = cfws.Cells(Rows.Count, "B").End(xlUp).Row
    
'   Apply Filter to name entered on Summary Sheet in Cell B1
    Set cfrng = cfws.Range("B1:H" & cflr)
    Set ctrng = ctws.Range("B" & ctlr)
    cfrng.AutoFilter
    cfrng.AutoFilter Field:=4, Criteria1:=selname
    cfrng.SpecialCells(xlCellTypeVisible).Copy
    ctrng.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    With ctws.Range("B" & ctlr - 2)
        .Value = "Meeting " & i
        .Font.Color = RGB(0, 176, 240)
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Name = "Arial"
        .Font.Size = 16
    End With
    
    cfws.AutoFilterMode = False
    startrow = ctlr
    
'   Reset next row to copy data to on Summary Worksheet to last row + 2
    ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row + 4
    
'   Put Border around last entry on Summary Worksheet
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(ctlr - 4, 8))
    With ctrng.Borders
        .LineStyle = xlContinuous
    End With
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(startrow, 8))
    With ctrng
        .Interior.Color = RGB(0, 176, 240)
        .Font.Color = vbWhite
    End With
            
    For x = startrow + 1 To ctlr - 4
        Range("F" & x).Value = Format(Range("F" & x), "Short Date")
    Next x
 Next i
    
Sheets("Summary").Select
With ctws
    .Range("B:B").ColumnWidth = 37
    .Range("C:C").ColumnWidth = 55
    .Range("D:D").ColumnWidth = 22
    .Range("E:E").ColumnWidth = 20
    .Range("F:F").ColumnWidth = 10
    .Range("G:G").ColumnWidth = 10
    .Range("H:H").ColumnWidth = 55
    .Columns("B:H").WrapText = True
    .Range("A1:H" & ctlr).Font.Name = "Arial"
End With


    MsgBox ("All copying has been completed")


End Sub
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

Hi Frank, I've been trying to fix one or two minor issues myself over the last few days, but I'm just worried about causing problems elsewhere with the code. I promise to leave you in peace and I'm really sorry to have to come back to you but is there any way that you'd be able to help me with four minor formatting issues that I can't seem to fix myself:

a) The headings (i.e. Reference, Description, ExCo Owner, Action Owner, Due Date, Complete?, Comment) do not seem to be copying. Would it be possible to amend this so that each table has the heading shown please?

b) I've renamed the worksheet names to reflect the name of the meeting. For example, one of the worksheets is named 'QBRs'. I've edited the code below to reflect the changes:

Select Case i
Case 1
Set cfws = Worksheets("QBRs")
Case 2
Set cfws = Worksheets("COO")
Case 3
Set cfws = Worksheets("Extended")
Case 4
Set cfws = Worksheets("Monthly")
Case 5
Set cfws = Worksheets("Group")

However I was hoping that the name of the active sheet would be reflected in the Summary Page so for example, instead of the title of the table on the summary page being 'Worksheet 1', it shows as 'QBRs' or 'Extended', etc - is that possible please? Relevant code is highlighted below:

With ctws.Range("B" & ctlr - 2)
.Value = "Worksheets" & i
.Font.Color = RGB(0, 176, 240)

c) Could you make it so that all cells not part of the table (i.e. Surrounding cells) are coloured white? The majority of cells already are but just from a simple formatting issue, it would look a lot cleaner if the cells surrounding the summary tables were all in white?

d) For the title's (i.e. What is currently showing as 'Worksheet 1, Worksheet 2, etc), would it be possible to not have these in borders please? So ideally the only bits that should be with borders are the tables but everything else should blank if possible please?

I can't thank you enough for all of your help. You've honestly saved my life. Would really appreciate these final few changes and then I promise to leave you in peace. THANK YOU :)
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

George,

I think I can fix all that but it may be tomorrow before I can work on it.

Frank
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

George,

I have made modifications that fixes everything but the issue of the Header not being carried over to the Summary page. The sample data sheets I created had the Headers in Row 1 with the data starting at Row 2 and it is adding the Headers to the Summary sheet as you had requested earlier.

Is it possible that there is a blank row between the Header and the first Row of data or that the Header is not in Row 1?

Let me know.

Thanks.

Frank

Code:
Option Explicit
Sub FilterCopyToSummary()


Dim cfws As Worksheet  ' Copy from Worksheet
Dim ctws As Worksheet  ' Copy to Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long       ' Copy from WS lastrow
Dim ctlr As Long       ' Copy to WS lastrow
Dim startrow As Long   ' First Row for Border
Dim i As Integer
Dim x As Integer
Dim selname As String


'   Copy data from Sheet1-Sheet5 and Paste in Summary Worksheet
'   Define Copy To Worksheet and Clear existing data
Set ctws = Worksheets("Summary")
With ctws.Cells.Font
    .Name = "Arial"
    .Size = 10
End With
ActiveWindow.DisplayGridlines = False


ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row
If ctlr > 5 Then
    With ctws
        .Range(.Cells(6, 1), .Cells(ctlr, 8)).Clear
    End With
End If
ctlr = 8
selname = ctws.Range("C5").Value
With Range("B2")
    .Value = "Summary of Actions - " & selname
    .Font.Color = RGB(0, 176, 240)
    .Font.Size = 16
End With
With ctws.Range("C5")
    .Borders.LineStyle = xlContinuous
End With


For i = 1 To 5
    If ctlr <= 5 Then
        ctlr = 8
    End If
    Select Case i
        Case 1
            Set cfws = Worksheets("QBRs")
        Case 2
            Set cfws = Worksheets("COO")
        Case 3
            Set cfws = Worksheets("Extended")
        Case 4
            Set cfws = Worksheets("Monthly")
        Case 5
            Set cfws = Worksheets("Group")
    End Select
    
'   Clear any existing Filters on the Copy From Worksheet and determine last row of data
    On Error Resume Next
    cfws.AutoFilterMode = False
    cflr = cfws.Cells(Rows.Count, "B").End(xlUp).Row
    
'   Apply Filter to name entered on Summary Sheet in Cell B1
    Set cfrng = cfws.Range("B1:H" & cflr)
    Set ctrng = ctws.Range("B" & ctlr)
    cfrng.AutoFilter
    cfrng.AutoFilter Field:=4, Criteria1:=selname
    cfrng.SpecialCells(xlCellTypeVisible).Copy
    ctrng.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    With ctws.Range("B" & ctlr - 2)
        .Value = cfws.Name
        .Font.Color = RGB(0, 176, 240)
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Name = "Arial"
        .Font.Size = 16
    End With
    
    cfws.AutoFilterMode = False
    startrow = ctlr
    
'   Reset next row to copy data to on Summary Worksheet to last row + 2
    ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row + 4
    
'   Put Border around last entry on Summary Worksheet
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(ctlr - 4, 8))
    With ctrng.Borders
        .LineStyle = xlContinuous
    End With
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(startrow, 8))
    With ctrng
        .Interior.Color = RGB(0, 176, 240)
        .Font.Color = vbWhite
    End With
            
    For x = startrow + 1 To ctlr - 4
        Range("F" & x).Value = Format(Range("F" & x), "Short Date")
    Next x
 Next i
    
Sheets("Summary").Select
With ctws
    .Range("B:B").ColumnWidth = 37
    .Range("C:C").ColumnWidth = 55
    .Range("D:D").ColumnWidth = 22
    .Range("E:E").ColumnWidth = 20
    .Range("F:F").ColumnWidth = 10
    .Range("G:G").ColumnWidth = 10
    .Range("H:H").ColumnWidth = 55
    .Columns("B:H").WrapText = True
End With


    MsgBox ("All copying has been completed")


End Sub
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

Hi Frank,

That's brilliant. It's working amazingly so a huge thank you!

In relation to the headings from copying across, you're correct that it is because the headings are always begin at Row 4, when I move them to Row 1, they copy across with no problem. As I need to keep titles in for each of the pages, would it be possible to amend the code so that the headings begin copying at Row 4, rather than Row 1 please?

The only other minor thing I was hoping that I could ask is for text to be aligned centrally and to the left? If you could do that then that would be brilliant.

I can't tell you how much grateful I am. A massive massive thank you! :)
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

George,

Copying now starts at Row 4 to capture the Header Rows.

On the Summary sheet I aligned everything Vertically to the Top of the cell since some of the Description and Action entries wrap to multiple row of text.
I aligned everything Horizontally to Left.

Let me know if that works for you.

Code:
Option Explicit
Sub FilterCopyToSummary()


Dim cfws As Worksheet  ' Copy from Worksheet
Dim ctws As Worksheet  ' Copy to Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long       ' Copy from WS lastrow
Dim ctlr As Long       ' Copy to WS lastrow
Dim startrow As Long   ' First Row for Border
Dim i As Integer
Dim x As Integer
Dim selname As String


'   Copy data from Sheet1-Sheet5 and Paste in Summary Worksheet
'   Define Copy To Worksheet and Clear existing data
Set ctws = Worksheets("Summary")
With ctws.Cells.Font
    .Name = "Arial"
    .Size = 10
End With
ActiveWindow.DisplayGridlines = False


ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row
If ctlr > 5 Then
    With ctws
        .Range(.Cells(6, 1), .Cells(ctlr, 8)).Clear
    End With
End If
ctlr = 8
selname = ctws.Range("C5").Value
With Range("B2")
    .Value = "Summary of Actions - " & selname
    .Font.Color = RGB(0, 176, 240)
    .Font.Size = 16
End With
With ctws.Range("C5")
    .Borders.LineStyle = xlContinuous
End With


For i = 1 To 5
    If ctlr <= 5 Then
        ctlr = 8
    End If
    Select Case i
        Case 1
            Set cfws = Worksheets("QBRs")
        Case 2
            Set cfws = Worksheets("COO")
        Case 3
            Set cfws = Worksheets("Extended")
        Case 4
            Set cfws = Worksheets("Monthly")
        Case 5
            Set cfws = Worksheets("Group")
    End Select
    
'   Clear any existing Filters on the Copy From Worksheet and determine last row of data
    On Error Resume Next
    cfws.AutoFilterMode = False
    cflr = cfws.Cells(Rows.Count, "B").End(xlUp).Row
    
'   Apply Filter to name entered on Summary Sheet in Cell B1
    Set cfrng = cfws.Range("B4:H" & cflr)
    Set ctrng = ctws.Range("B" & ctlr)
    cfrng.AutoFilter
    cfrng.AutoFilter Field:=4, Criteria1:=selname
    cfrng.SpecialCells(xlCellTypeVisible).Copy
    ctrng.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    With ctws.Range("B" & ctlr - 2)
        .Value = cfws.Name
        .Font.Color = RGB(0, 176, 240)
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Name = "Arial"
        .Font.Size = 16
    End With
    
    cfws.AutoFilterMode = False
    startrow = ctlr
    
'   Reset next row to copy data to on Summary Worksheet to last row + 2
    ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row + 4
    
'   Put Border around last entry on Summary Worksheet
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(ctlr - 4, 8))
    With ctrng.Borders
        .LineStyle = xlContinuous
    End With
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(startrow, 8))
    With ctrng
        .Interior.Color = RGB(0, 176, 240)
        .Font.Color = vbWhite
    End With
            
    For x = startrow + 1 To ctlr - 4
        Range("F" & x).Value = Format(Range("F" & x), "Short Date")
    Next x
 Next i
    
Sheets("Summary").Select
With ctws
    .Range("B:B").ColumnWidth = 37
    .Range("C:C").ColumnWidth = 55
    .Range("D:D").ColumnWidth = 22
    .Range("E:E").ColumnWidth = 20
    .Range("F:F").ColumnWidth = 10
    .Range("G:G").ColumnWidth = 10
    .Range("H:H").ColumnWidth = 55
    .Columns("B:H").WrapText = True
    .Columns("B:H").HorizontalAlignment = xlLeft
    .Range("B6:H" & ctlr).VerticalAlignment = xlTop
End With




    MsgBox ("All copying has been completed")


End Sub
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

Frank - thank you so much. It's working brilliantly and I can't tell how much time it's going to save me! You're an absolute lifesaver.:):):):)

No worries if you can't as you've done more than enough but some of the actions are listed as 'All' instead of an individual's name and therefore are not capturing on the summary sheet. Is there a way that a slight modification of the code could be added so that any actions which are listed as 'All' are automatically added to the summary sheet for all users.

No problem if not as I can't thank you enough for the time you've spent so far. It's looking brilliant - I'm sad to say that I'm actually very excited about using it.



George,

Copying now starts at Row 4 to capture the Header Rows.

On the Summary sheet I aligned everything Vertically to the Top of the cell since some of the Description and Action entries wrap to multiple row of text.
I aligned everything Horizontally to Left.

Let me know if that works for you.

Code:
Option Explicit
Sub FilterCopyToSummary()


Dim cfws As Worksheet  ' Copy from Worksheet
Dim ctws As Worksheet  ' Copy to Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long       ' Copy from WS lastrow
Dim ctlr As Long       ' Copy to WS lastrow
Dim startrow As Long   ' First Row for Border
Dim i As Integer
Dim x As Integer
Dim selname As String


'   Copy data from Sheet1-Sheet5 and Paste in Summary Worksheet
'   Define Copy To Worksheet and Clear existing data
Set ctws = Worksheets("Summary")
With ctws.Cells.Font
    .Name = "Arial"
    .Size = 10
End With
ActiveWindow.DisplayGridlines = False


ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row
If ctlr > 5 Then
    With ctws
        .Range(.Cells(6, 1), .Cells(ctlr, 8)).Clear
    End With
End If
ctlr = 8
selname = ctws.Range("C5").Value
With Range("B2")
    .Value = "Summary of Actions - " & selname
    .Font.Color = RGB(0, 176, 240)
    .Font.Size = 16
End With
With ctws.Range("C5")
    .Borders.LineStyle = xlContinuous
End With


For i = 1 To 5
    If ctlr <= 5 Then
        ctlr = 8
    End If
    Select Case i
        Case 1
            Set cfws = Worksheets("QBRs")
        Case 2
            Set cfws = Worksheets("COO")
        Case 3
            Set cfws = Worksheets("Extended")
        Case 4
            Set cfws = Worksheets("Monthly")
        Case 5
            Set cfws = Worksheets("Group")
    End Select
    
'   Clear any existing Filters on the Copy From Worksheet and determine last row of data
    On Error Resume Next
    cfws.AutoFilterMode = False
    cflr = cfws.Cells(Rows.Count, "B").End(xlUp).Row
    
'   Apply Filter to name entered on Summary Sheet in Cell B1
    Set cfrng = cfws.Range("B4:H" & cflr)
    Set ctrng = ctws.Range("B" & ctlr)
    cfrng.AutoFilter
    cfrng.AutoFilter Field:=4, Criteria1:=selname
    cfrng.SpecialCells(xlCellTypeVisible).Copy
    ctrng.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    With ctws.Range("B" & ctlr - 2)
        .Value = cfws.Name
        .Font.Color = RGB(0, 176, 240)
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Name = "Arial"
        .Font.Size = 16
    End With
    
    cfws.AutoFilterMode = False
    startrow = ctlr
    
'   Reset next row to copy data to on Summary Worksheet to last row + 2
    ctlr = ctws.Cells(Rows.Count, "B").End(xlUp).Row + 4
    
'   Put Border around last entry on Summary Worksheet
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(ctlr - 4, 8))
    With ctrng.Borders
        .LineStyle = xlContinuous
    End With
    Set ctrng = ctws.Range(Cells(startrow, 2), Cells(startrow, 8))
    With ctrng
        .Interior.Color = RGB(0, 176, 240)
        .Font.Color = vbWhite
    End With
            
    For x = startrow + 1 To ctlr - 4
        Range("F" & x).Value = Format(Range("F" & x), "Short Date")
    Next x
 Next i
    
Sheets("Summary").Select
With ctws
    .Range("B:B").ColumnWidth = 37
    .Range("C:C").ColumnWidth = 55
    .Range("D:D").ColumnWidth = 22
    .Range("E:E").ColumnWidth = 20
    .Range("F:F").ColumnWidth = 10
    .Range("G:G").ColumnWidth = 10
    .Range("H:H").ColumnWidth = 55
    .Columns("B:H").WrapText = True
    .Columns("B:H").HorizontalAlignment = xlLeft
    .Range("B6:H" & ctlr).VerticalAlignment = xlTop
End With




    MsgBox ("All copying has been completed")


End Sub
 
Upvote 0
Re: Pulling Multiple Worksheets into Summary Sheet - VBA Help

George,

Help me understand this last request. The way the code works now is that it finds the last row of data on each of the 5 Worksheets (based on Column B) and copies all rows from Row 4 (Header Row) to that last Row.
With that in mind, where are these rows of data that are "All" located? It may help if you could post a picture of one of your data sheets (change any personally identifiable data) so that I can better understand what is happening.
As you know, I built a simple model in order to test the code and apparently there are nuances in the actual data I have not effectively captured.

Frank
 
Upvote 0

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top