Combining Selected Worksheets into One

[Vlr516]

I am spending way too much time combining worksheets onto a summary sheet. Is there vba code that could do this for me? I must combine worksheets together that have "REQ" somewhere in the tab name within the active workbook which could be one tab or several. My only worry here is the author of the workbook could have changed the name of the tab.

The other way I could do it is have a list of sheets in the workbook, and I select the tabs would like to combine.

I am not sure of which option to choose or how to start the code for this one. Any suggestions?

 

[ismii]

Even if the name of the sheet changes, is the format the same for each sheet?

You could check to see if the header matches, or some other value that is constant across all the sheets you would like to compile.

If you go the route of selecting the sheets individually, you could have a User Form that has a multi-select listbox, and even could have the sheets with "REQ" in their names be selected automatically as well.

Code-wise, the basic idea would be the same in that you'd loop through each sheet and if it follows what you want, copy/paste onto a summary sheet that you made.

 

[Vlr516]

Yes, the format is the same for each sheet.

I think I would like to go the route of the User Form although I have never done vba for one before. What would be the basic code to doing that just to get started?

 

[bsquad]

you would really need to provide more detail give that you don't know the distinction of what workbooks you need to aggregate / compile.

here is a VERY BASIC start to what you are looking for - I can't emphasize the word BASIC any more than all caps; if you were to provide more detail there could be a more complex code written.

Sub Agg()
    Dim eSheet As Worksheet
        Set eSheet = ThisWorkbook.Worksheets("Summary")
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iSheet As Worksheet

        For i = 1 To eWorkbook.Worksheets.Count
            For Each iSheet In eWorkbook.Worksheets
                If iSheet.Name Like "REQ*" Then
                iSheet.Activate
                    Dim ERx As Long
                        ERx = Cells(Rows.Count, "A").End(xlUp).Row
                    Dim LRx As Long
                        LRx = Cells(1, Columns.Count).End(xlToLeft).Column
                    With iSheet: .Range(Cells(1, 1), Cells(ERx, LRx)).Copy: End With
                      With eSheet.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)
                            .PasteSpecial Paste:=xlPasteAll
                      End With
                                    Application.CutCopyMode = False
                End If
            Next iSheet
        Next i
End Sub

 

[Vlr516]

Bsquad:

All of the worksheets are inside one workbook. There are well over 20 sheets in the workbook, and I only need to capture data from those that have "Req" or fully say "Requirements" (I thought Req would be a better evaluation). All the Requirements/Req sheets are formatted the same, data starting on row 6. There may be some blank rows on the Requirements/Req sheets that I don't want carried over to the Test sheet.

Worksheets that meet "If sht.Name Like "Req*" Then"
* I need to concatenate 2 columns "shtTest.Cells(j,1).Value = ReqNo & "--" ReqName"
* I need to bring over 1 column as is "shtTest.Cells(j, 8).Value = Desc"

Below is an attempted code based on another macro and what you listed above. However, I couldn't get it to work.

Sub Test()
Dim wbAs Workbook
Dim shtTest As Worksheet
Dim sht As Worksheet
Dim ReqNo As String, ReqName As String
Dim FinalRow As Long, FinalCol As Long, i As Long, r As Long, j As Long

With Application
    .ScreenUpdating = False
End With

Set wb = ThisWorkbook
Set shtTest = wbPPM.Worksheets("Summary")
FinalRow = Cells(Rows.Count, 3).End(xlUp).Row
finalCol = Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To wb.Worksheets.Count
    For Each sht In wb.Worksheets
        If sht.Name Like "Req*" Then
            r = 6
            j = 6
            If sht.Cells(r, 3) <> "" Then
                ReqNo = sht.Cells(r, 1).Value
                ReqName = sht.Cells(r, 3).Value
                shtTest.Cells(j,1).Value = ReqNo & "--" ReqName
                Desc = sht.Cells(r, 4).Value
                shtTest.Cells(j, 8).Value = Desc
                j = j + 1
            End If
        End If
    Next sht
Next i

End Sub

 

[bsquad]

If I am understanding right from your reply; in the 'Summary' sheet - it will only have data in Col A and Col H
One thing to take note
-I am not the biggest fan of validation off of a tab name(its more of a personal style preference), regardless theres nothing wrong with it. But it is case sensitive; I am not really best with 'like' statements unless its in SQL, so you might have to search for another method.

Sub Agg()
    Dim eSheet As Worksheet
        Set eSheet = ThisWorkbook.Worksheets("Summary")
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iSheet As Worksheet
    Dim i, xIndex, yIndex, SxIndex, SyIndex, ExIndex As Long
        ExIndex = 6
        SxIndex = 6
        SyIndex = 1

        For i = 2 To eWorkbook.Worksheets.Count
            For Each iSheet In eWorkbook.Worksheets
                If iSheet.Name Like "Req*" Then
                    For yIndex = 1 To iSheet.Cells(6, Columns.Count).End(xlToLeft).Column
                        For xIndex = 6 To iSheet.Cells(Rows.Count, "A").End(xlUp).Row
                            If iSheet.Cells(xIndex, yIndex) <> "" Then
                                With eSheet
                                    eSheet.Cells(SxIndex, SyIndex).Value = iSheet.Cells(ExIndex, 1).Value & "--" & iSheet.Cells(ExIndex, 3).Value
                                    eSheet.Cells(SxIndex, 8).Value = iSheet.Cells(ExIndex, 4).Value
                                End With
                            ExIndex = ExIndex + 1
                            Else: ExIndex = ExIndex + 1: GoTo xIndex
                            End If
                        SxIndex = SxIndex + 1
xIndex:                 Next xIndex
                    Next yIndex
                End If
            Next iSheet
        Next i
End Sub

 

[bsquad]

Disregard that last one - use this one

Sub Agg()
    Dim eSheet As Worksheet
        Set eSheet = ThisWorkbook.Worksheets("Summary")
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iSheet As Worksheet
    Dim i, xIndex, yIndex, SxIndex, SyIndex, ExIndex As Long
        SxIndex = 6
        SyIndex = 1
            For Each iSheet In eWorkbook.Worksheets
                If Mid(iSheet.Name, 1, 3) = "Req" Then
                ExIndex = 6
                    For ExIndex = 6 To iSheet.Cells(Rows.Count, "A").End(xlUp).Row
                        If iSheet.Cells(ExIndex, 1) <> "" Then
                            With eSheet
                                eSheet.Cells(SxIndex, SyIndex).Value = iSheet.Cells(ExIndex, 1).Value & "--" & iSheet.Cells(ExIndex, 3).Value
                                eSheet.Cells(SxIndex, 8).Value = iSheet.Cells(ExIndex, 4).Value
                            End With
                            ExIndex = ExIndex + 1
                        Else: ExIndex = ExIndex + 1: GoTo ExIndex
                        End If
                    SxIndex = SxIndex + 1
ExIndex:            Next ExIndex
                Else: GoTo Nexti
                End If
Nexti:       Next iSheet
End Sub

 

[Vlr516]

bsquad:

I was able to get most of the code to work, thank you. The part that isn't working is if my FinalRow (iSheet.Cells(Rows.Count, "A").End(xlUp).Row) is 11, it is copying all the data up to row 10 and listing on my Summary sheet. However, it then moves onto the next sheet and skips data in row 11. Any thoughts as to why?

 

[bsquad]

add a "+1" after .Row

>>.End(xlUp).Row + 1

 

[ismii]

You could also use lcase() to make sure you match without depending on casing.