Consolidate Worksheets into a Single Worksheet

Ken_W

New Member
Joined
May 7, 2015
Messages
17
I have a Workbook with several hundred worksheets, which I need to merge/consolidate into a single worksheet. I found some code that I was able to slightly modify for my purposes and works perfect with the exception of some formatting of the data problems. I have a test version of my workbook here:
https://app.box.com/s/8wju200wyh8mxmsda1q9ajsh9gi4txjy

Most of the data is consolidated correctly, however, some of the data formats are changed in column D and Column H. For example, there's a worksheet names 0447 and column D's value is 0447, but when I run the code it drops the leading zero.

Regarding column H, this data is often interpreted as a date, but it's not and it needs to maintain its original value e.g. 1-1-1 vice 1/1/2001.

So basically I need columns D and H to be formatted as text to maintain the values. I don't want to format all columns to text, as some columns do have numerical values, which I need to maintain.

Just to be clear, I'm not a VBA coder and as I said, most of this was pulled from another source I found.

Thanks in advance!

Ken

The code is as follows:
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Range("A1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Selection.AutoFilter
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
11,275
Office Version
2013
Platform
Windows
Have you tried manually to format the columns by selecting the columns,right clicking on the sheet, choose 'Format Cells' from the pop up menu, choose 'Custom' in the dialog box and then find and click on the '@' symbol? That will allow the numeric entries to retain their leading zeros, but also maintain numeric characteristics. You don't need VBA to format rows and columns on a sheet.
 

Ken_W

New Member
Joined
May 7, 2015
Messages
17
Thanks for the tip, but no, I need a VBA solution due to the hundreds of worksheets I'm working with. And this is just one workbook. In the end I'll have several hundred workbooks with several hundreds of worksheets each.
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
11,275
Office Version
2013
Platform
Windows
Thanks for the tip, but no, I need a VBA solution due to the hundreds of worksheets I'm working with. And this is just one workbook. In the end I'll have several hundred workbooks with several hundreds of worksheets each.
Oh, I thought it was the consolidated sheet that was giving the format problem.
 

Ken_W

New Member
Joined
May 7, 2015
Messages
17
Well, it is creating the consolidated sheet that is causing the format problem, but once the consolidated sheet is created, the data format is already screwed up. So formatting after the fact doesn't help anyway.
 

Ken_W

New Member
Joined
May 7, 2015
Messages
17
Just checking to see if anyone had any suggestions on this...
 

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
669
The following will combine all spreadsheets in a workbook if the columns are all the same. Make sure there are no blank worksheets.





Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
 

Ken_W

New Member
Joined
May 7, 2015
Messages
17
The following will combine all spreadsheets in a workbook if the columns are all the same. Make sure there are no blank worksheets.
End Sub
I agree it does, it's essentially the same code I was using minus the part I added. It also has the same problem. I need columns D and H to be formatted as text to maintain the values as they are in the original spreadsheets that I am consolidating.
 

Ken_W

New Member
Joined
May 7, 2015
Messages
17
Just checking to see if anyone had any suggestions on this...
 

DocAElstein

Banned user
Joined
May 24, 2014
Messages
1,336
Hi Ken,
. Thanks for the PM.
. I am a beginner myself and got the following code by simply using a macro recording to do the extra column formatting change to text. So maybe I have missed the point, but I think this code gives you what you want... ( I found I only needed to change the text format in the Master ( trg ) sheet for the code to work by me. I guess to be on the safe side you could do a similar couple of lines to change the column format to text in each sheet )

. Here is the code, extra lines shown in orange

Code:
[COLOR=blue]Sub[/COLOR] CopyFromWorksheets()
    [COLOR=blue]Dim[/COLOR] wrk [COLOR=blue]As[/COLOR] Workbook [COLOR=lightgreen]'Workbook object - Always good to work with object variables[/COLOR]
    [COLOR=blue]Dim[/COLOR] sht [COLOR=blue]As[/COLOR] Worksheet [COLOR=lightgreen]'Object for handling worksheets in loop[/COLOR]
    [COLOR=blue]Dim[/COLOR] trg [COLOR=blue]As[/COLOR] Worksheet [COLOR=lightgreen]'Master Worksheet[/COLOR]
    [COLOR=blue]Dim[/COLOR] rng [COLOR=blue]As[/COLOR] Range [COLOR=lightgreen]'Range object[/COLOR]
    [COLOR=blue]Dim[/COLOR] colCount [COLOR=blue]As[/COLOR] [COLOR=blue]Integer[/COLOR] 'Column count in tables in the worksheets
    
    [COLOR=blue]Set[/COLOR] wrk = ActiveWorkbook [COLOR=lightgreen]'Working in active workbook[/COLOR]
    
    [COLOR=blue]For[/COLOR] [COLOR=blue]Each[/COLOR] sht [COLOR=blue]In[/COLOR] wrk.Worksheets
        [COLOR=blue]If[/COLOR] sht.Name = "Master" [COLOR=blue]Then[/COLOR]
            MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
            "Please remove or rename this worksheet since 'Master' would be" & _
            "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
            [COLOR=blue]Exit[/COLOR] [COLOR=blue]Sub[/COLOR]
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
    [COLOR=blue]Next[/COLOR] sht
    
     [COLOR=lightgreen]'We don't want screen updating[/COLOR]
     Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
    
     [COLOR=lightgreen]'Add new worksheet as the last worksheet[/COLOR]
    [COLOR=blue]Set[/COLOR] trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
     [COLOR=lightgreen]'Rename the new worksheet[/COLOR]
    trg.Name = "Master"
     [COLOR=lightgreen]'Get column headers from the first worksheet[/COLOR]
     [COLOR=lightgreen]'Column count first[/COLOR]
    [COLOR=blue]Set[/COLOR] sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column
     [COLOR=lightgreen]'Now retrieve headers, no copy&paste needed[/COLOR]
    [COLOR=blue]With[/COLOR] trg.Cells(1, 1).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
         [COLOR=lightgreen]'Set font as bold[/COLOR]
        .Font.Bold = [COLOR=blue]True[/COLOR]
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
        [COLOR=lightgreen]'Change column D and H to text format in trg sheet.[/COLOR]
        [COLOR=orange]trg.Columns("D:D").NumberFormat = "@"
        trg.Columns("H:H").NumberFormat = "@"[/COLOR]
    
     [COLOR=lightgreen]'We can start loop[/COLOR]
    [COLOR=blue]For[/COLOR] [COLOR=blue]Each[/COLOR] sht [COLOR=blue]In[/COLOR] wrk.Worksheets
         [COLOR=lightgreen]'If worksheet in loop is the last one, stop execution (it is Master worksheet)[/COLOR]
        [COLOR=blue]If[/COLOR] sht.Index = wrk.Worksheets.Count [COLOR=blue]Then[/COLOR]
        Range("A1").Select
        [COLOR=blue]With[/COLOR] ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
        [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
        ActiveWindow.FreezePanes = [COLOR=blue]True[/COLOR]
        Selection.AutoFilter
    [COLOR=blue]Exit[/COLOR] [COLOR=blue]For[/COLOR]
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
         [COLOR=lightgreen]'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets[/COLOR]
       
        [COLOR=blue]Set[/COLOR] rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
         [COLOR=lightgreen]'Put data into the Master worksheet[/COLOR]
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
    [COLOR=blue]Next[/COLOR] sht
     [COLOR=lightgreen]'Fit the columns in Master worksheet[/COLOR]
    trg.Columns.AutoFit
    
     [COLOR=lightgreen]'Screen updating should be activated[/COLOR]
    Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End[/COLOR] [COLOR=blue]Sub[/COLOR]

Alan

P.s. 1 Nice 'commented code you found – where did you find it?

p.s.2
Well, it is creating the consolidated sheet that is causing the format problem, but once the consolidated sheet is created, the data format is already screwed up. So formatting after the fact doesn't help anyway.
..... I format in the code before anything is copied, so that overcomes that problem
 
Last edited:

Forum statistics

Threads
1,082,040
Messages
5,362,804
Members
400,693
Latest member
jenlj

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top