Merge data from many many tabs (worksheets) into a new sheet

[dmellor2]

Hi All,

I need help from anyone who has done this before or can easily help me....

Basically I inherited a Excel Workbook which has 128 different tabs, unsurprising this is almost impossible to manage.

My requirement is to merge all of the 128 tabs into 1 tab 'Sheet1'.
The macro should keep going even if there are blanks, it should move onto the next tab only when there are over 10 consecutive blanks in Column B.

I have tried searching the forum but nothing seems to cater for the specifics of this case. I would really appreciate some help. I mean really, i am in a mad panic thinking i will have to do 128 tabs manually otherwise.

Thanks, Darren

 

[dmellor2]

Any ideas

Thanks.

 

[tstav]

merge all of the 128 tabs into 1 tab 'Sheet1'......The macro should move onto the next tab only when there are over 10 consecutive blanks in Column B

If I understand correctly, the only case that you want to skip a Sheet is when there are at least 11 consecutive blank cells in column B, NO MATTER WHERE THEY ARE?
I mean,
Option 1: If these blank cells start from cell B20 up to B31, would that mean you skip that Sheet or not?
Option 2: Or is it that you want to skip a Sheet only when the FIRST 11 cells of column B are blank?
Please be specific on this. My guess is that you mean option number 2, but I'm waiting for your word...

 

[Mark F]

Hi Darren

Something like the code below will meet your needs I think

Mark

Sub MergeTabsOntoNewSheet()
'========================================================================
' THIS MERGES "VALUES" AND FORMATTING OF ALL SHEETS IN WORKBOOK
' ONTO A NEW SHEET ADDED AS FIRST SHEET
'========================================================================
    Dim ws As Worksheet
    Sheets.Add Before:=Sheets(1)
   Sheets(1).Activate
   ActiveSheet.UsedRange.Offset(0).Clear
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then
            ws.UsedRange.Copy
            With Range("A65536").End(xlUp).Offset(1, 0)
                .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                              False, Transpose:=False
                .PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                              False, Transpose:=False
            End With
        End If
    Next
End Sub

 

[Mark F]

Or this

Mark

Sub CombineSheets()
'========================================================================
' THIS MERGES CONTENTS OF ALL SHEETS IN WORKBOOK ONTO A NEW
' SHEET COLUMNS A TO F  - Change as needed
'========================================================================
    Dim wsDst As Worksheet
    Dim wsSrc As Worksheet
    Dim LastRowDst As Long
    Dim LastRowSrc As Long
    Set wsDst = Worksheets.Add
    LastRowDst = 1
    For Each wsSrc In Worksheets
        If wsSrc.Name <> wsDst.Name Then
            LastRowSrc = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
' Change the "A1:F" to whatever columns needed
            wsSrc.Range("A1:F" & LastRowSrc).Copy wsDst.Range("A" & LastRowDst)
 
            LastRowDst = LastRowDst + LastRowSrc
        End If
    Next wsSrc
End Sub

 

[dmellor2]

Hi

tstav - it is Option A actually i am after. So if there are 10+ empty cells in Column B we can stop copying and pasting from that tab and move onto the next one (safe in the knowledge there is no more data we have missed)

This is the only way to cater for the messed up gaps in the spreadsheets I am afraid

Mark - I tried both examples, the 2nd seemed a closer match, but both of them didn't quite pull off all the data, i.e. in checking the 1st tab was fully copied, both stopped on row 60 for some strange reason. The only thing i can see is that row A has a lot of blanks but has an entry for row 60.

I do think the best way to include all is copy every row until there are 10+ consecutive blank cells in Column B and on this condition move onto the next tab

Thanks for all your help so far

 

[tstav]

dmellor2, I'll get back to you either in about five hours from now, or tomorrow morning. Sorry for not being able to help right now.
Thanks for the clarifications.

 

[tstav]

So if there are 10+ empty cells in Column B we can stop copying and pasting from that tab and move onto the next one (safe in the knowledge there is no more data we have missed)

Hi Darren,
I understand that the reason you are thinking of copying data on a row by row basis is so that you can check for 10+ consecutive blanks in col B. If so, you choose to stop copy/paste from that Sheet and move to the next Sheet. Still, as you say, we can only ASSUME that there is no more data there.
Now here is what I say: Why not copy/paste the whole bunch of data from every Sheet, without worrying about any possible blanks. If there is data (wherever it is) we SHOULD copy it. Are you sure we can afford losing data?

In this respect, here is the code I submit, hoping that it will be of help to you

Sub MergeSheets()
'''''''''''''''''''''''''''''''''''''''''''''''''
'Copy data from all Worksheets to a new Worksheet
'''''''''''''''''''''''''''''''''''''''''''''''''
Dim intI, intSheetsCount As Integer
Dim blnFirstCopyComplete As Boolean
Dim NewSheet As Worksheet
Dim rngRange As Range
Dim lngLastRow
'Create a new Worksheet and move it before all Worksheets
Set NewSheet = ActiveWorkbook.Worksheets.Add(Before:=Worksheets(1))
'Get the number of Worksheets
intSheetsCount = ActiveWorkbook.Worksheets.Count
'Excluding the new Worksheet, copy all other Worksheets
'one by one
For intI = 2 To intSheetsCount
   
   'This is the Range that will be copied to the new Worksheet
   With ActiveWorkbook.Worksheets(intI)
      Set rngRange = .Range(.Cells(1, 1), _
         .Cells.SpecialCells(xlCellTypeLastCell))
   End With
   
   With NewSheet
      'If this is the first paste, do it on the first row
      If Not blnFirstCopyComplete Then
         rngRange.Copy Destination:=.Cells(1, 1)
         blnFirstCopyComplete = True
      'Else, first find the cell where the copied range will be
      'pasted and proceed with the paste
      Else
         'This is last row of the so far created new Worksheet data
         lngLastRow = .Range(.Cells(1, 1), _
            .Cells.SpecialCells(xlCellTypeLastCell)).Rows.Count
         'Do the paste on the next row
         rngRange.Copy Destination:=.Cells(lngLastRow + 1, 1)
      End If
   End With
Next 'intI
End Sub

Greetings!

 

[dmellor2]

Thanks tstav.

Your answer works, i tested a few awkward tabs of data and it all copied across fine.

Your help has been much appreciated.

Darren

 

[tstav]

Glad to have been of help, Darren
Have a nice day