PDA

View Full Version : Tweaking the "Combine all Worksheets in One" VBA



aldonix
01-11-2008, 08:24 AM
I was looking for a Macro to combine worksheets into one. I have finally found the appropriate Macro on this webstie, but still have a couple problems with it. Since I am not a VBA whizz :banghead: , I would like to ask for some help.

1. Becuase my content is formated (red and black font), I would also need the macro to to copy the formating from the worksheets into the new worksheet "Master".

2. Would it be possible to include in the Macro, that it would take the Worksheet name and display it in the "master" under collumn C for this example.

3. Since I also have some hidden worksheets, I would like the macro, just to combine the ones which are not hidden. how would that be possible?

I am attaching a little example of what I mean, the doccument for which I would need this is a bit bigger :)

thank you very much!

This is the macro I used from vbaexpress.com:

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

stanleydgrom
01-13-2008, 02:29 PM
aldonix,

The following code has been tested in your attached workbook, and works correctly per your requirements.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Copy the below code, and paste it into the Module1.




Option Explicit
Sub CopyFromAllSheetsButMaster()
Dim wSheet As Worksheet
Dim wsTarget As Worksheet
Dim strActiveSheetName As String
Dim lngwSheetLastRow As Long
Dim lngTargetLastRow As Long
Application.ScreenUpdating = False
Set wsTarget = Worksheets("Master")
For Each wSheet In Worksheets
If UCase(wSheet.Name) = "MASTER" Then
'Do nothing
Else
lngwSheetLastRow = wSheet.Range("A" & Rows.Count).End(xlUp).Row
lngTargetLastRow = Worksheets("Master").Range("A" & Rows.Count).End(xlUp).Row + 1
With wSheet
.Range("A2:B" & lngwSheetLastRow).Copy wsTarget.Cells(lngTargetLastRow, 1)
Application.CutCopyMode = False
End With
End If
Next wSheet
wsTarget.Select
Application.ScreenUpdating = True
End Sub



Then run the "CopyFromAllSheetsButMaster" macro from any active sheet in your workbook.

Have a great day,
Stan