[Webinar] Learn how to a build a cloud-first strategyRegister Now

  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 592
  • Last Modified:

Combine specific worksheets into one

I have a number of tabs that i need to combine into one.  There are a total of 9 tabs and I only need 8.  I have created a tab called 'combine' to accept all of the data but i need to not pull in the data from a tab named 'summary'.  how do you combine specific tabs?  

  • 4
  • 2
  • 2
  • +1
1 Solution
Ardhendu SarangiSr. Project ManagerCommented:
either you can copy and paste data from different sheets into one manually or you can use a macro. but to create a macro, it would require to see the original spreadsheet and the expected result. can you please post a sample file here?
farmingtonisAuthor Commented:
no i can't sorry.  never had to do that before but thanks.
farmingtonisAuthor Commented:
oh, but i can tell you there are a total of 33 columns and the rows counts are variable.  does that help?  Each sheet should be placed on the other then without the header one after the other.

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Ardhendu SarangiSr. Project ManagerCommented:
sorry but your requirements seem a bit vague to me.

its hard to understand when you say combine, do you mean to copy over each tab to the left of the other tabs..so columns 1 thru 33 are sheet 1, 34 thru 66 are sheet 2 and so on

or you want to copy and paste the data one below the other..

unless you have a spreadsheet, its too difficult for me to even start something. you can provide a dummy file, need not be the actual data in it.

Saqib Husain, SyedEngineerCommented:
Try this macro. This is the best I can do without a sample.


Sub combsheets()
Set ts = Worksheets("Combine")
For Each ws In ThisWorkbook.Worksheets
If LCase(ws.Name) <> "combine" And LCase(ws.Name) <> "summary" Then
ws.UsedRange.Copy ts.Cells(ts.UsedRange.Row + ts.UsedRange.Rows.Count, 1)
End If
Next ws
End Sub
farmingtonisAuthor Commented:
It only gets the first row.  Below is the code that pulls in all of the data from each sheet.

Public Function STEP1()
   Dim SourceWorksheet As Worksheet
   Dim SourceRange As Range
   Dim DestRow As Long
   ' Change the following constant if the first source row is not row 2 on each worksheet
   Const FirstSourceRow = 1
   Application.ScreenUpdating = False
   DestRow = IIf(Sheet1.UsedRange.Address = "$A$1", 1, Sheet1.UsedRange.SpecialCells(xlLastCell).Row + 1)
   For Each SourceWorksheet In ThisWorkbook.Worksheets
      If Not SourceWorksheet Is ActiveSheet Then
         If SourceWorksheet.UsedRange.Rows.Count >= FirstSourceRow Then
            Set SourceRange = SourceWorksheet.UsedRange.Offset(FirstSourceRow - 1).Resize(SourceWorksheet.UsedRange.Rows.Count - FirstSourceRow + 1)
            Sheet1.Rows(DestRow).Resize(SourceRange.Rows.Count, SourceRange.Columns.Count).Value = SourceRange.Value
            Sheet1.Rows(DestRow).Resize(SourceRange.Rows.Count, SourceRange.Columns.Count).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
            DestRow = DestRow + SourceRange.Rows.Count
         End If
      End If
   Next SourceWorksheet
   Application.ScreenUpdating = True
End Function
Saqib Husain, SyedEngineerCommented:

      If Not SourceWorksheet Is ActiveSheet Then

If Not SourceWorksheet Is ActiveSheet and LCase(ws.Name) <> "summary" Then

Dave BrettCommented:
My Article offers this abilityto do this  http://www.experts-exchange.com/A_2804.htm
(ie iii below)
                 i. Collate all sheets from all Excel workbooks in a single folder into a single summary worksheet
                 ii. Collate all sheets from all Excel workbooks in a single folder into a single summary workbook
                iii. Collate all sheets from a single Excel workbook into a single summary worksheet

I have changed this line below to avoid the summary page
 If Not rng2 Is Nothing and ws2.name <> "summary" Then


Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant

 bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (TRUE)," & vbNewLine & "or a target file sheet for each source sheet(FALSE)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "C:\temp"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
    lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls), *.xls")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        For Each ws2 In Wb2.Sheets
            If bNewSheet Then
                'All data to a single sheet
                'Skip importing target sheet data if the source sheet is blank
                Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

                If Not rng2 Is Nothing And ws2.Name <> "summary" Then
                    Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                    'Find the first blank row on the target sheet
                    If Not rng1 Is Nothing Then
                        Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                        'Ensure that the row area in the target sheet won't be exceeded
                        If rng3.Rows.Count + rng1.Row < Rows.Count Then
                            'Copy the data from the used range of each source sheet to the first blank row
                            'of the target sheet, using the starting column address from the source sheet being copied
                            ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                            MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                   "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                            Wb2.Close False
                            Exit Do
                        End If
                        'colour the first of any spacer rows
                        If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                        'target sheet is empty so copy to first row
                        ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2
        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Cells(1).PasteSpecial xlPasteValues
        End With
        'Format the summary sheet if the user has created separate target sheets
        ws1.Range("A1:B1").Font.Bold = True
    End If

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article

    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

Open in new window

farmingtonisAuthor Commented:
Took a little tweaking on my part but good stuff.

Featured Post

Get your Disaster Recovery as a Service basics

Disaster Recovery as a Service is one go-to solution that revolutionizes DR planning. Implementing DRaaS could be an efficient process, easily accessible to non-DR experts. Learn about monitoring, testing, executing failovers and failbacks to ensure a "healthy" DR environment.

  • 4
  • 2
  • 2
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now