Solved: Combine coloured sheets from files

[ChrisL]

Hey,

I have a question and I hope someone can help me with this. I have about 2000 excel-files which I need to combine into one or several files. I've just tried this script by mvidas (can't post the link because I don't have 5 posts:) ) which worked incredibly well but wasn't perfect for what I'm trying to do. Since I'm not that good at writing scripts I hope someone here can help me.
The problem is: I have given the cells in my sheets a colour which I want to copy too, but the script from mvidas doesn't do that. Is it possible to do so and if so: how?
It would save me a lot of time if someone could help me with this.

Thanx in advance,

Chris

[mdmackillop]

Welcome to VBAX
Did you mean this code?
http://www.vbaexpress.com/kb/getarticle.php?kb_id=773

[monarchd]

Well, without seeing the script, I would think using Move instead of Copy would preserve the formatting. Always save backups before modifying any code.

I'm thinking, as an example, if in the code you see


ActiveSheet.Copy


try instead


ActiveSheet.Move


Sample code formatting for .Copy and .Move is here at MS: http://support.microsoft.com/kb/288402

Alternately, see if this JMC tool will get the job done:

http://jeeshenlee.wordpress.com/2010/09/23/jmc-excel-join-merge-combine-multiple-excel-sheets-or-excel-workbooks/

[mdmackillop]

If I have the right code, try this, which should copy formats as noted (untested)
Option Explicit

Sub CombineSheetsFromAllFilesInADirectory()
'Uses methods found in http://vbaexpress.com/kb/getarticle.php?kb_id=151 and
' http://vbaexpress.com/kb/getarticle.php?kb_id=221

Dim Path As String 'string variable to hold the path to look through
Dim FileName As String 'temporary filename string variable
Dim tWB As Workbook 'temporary workbook (each in directory)
Dim tWS As Worksheet 'temporary worksheet variable
Dim mWB As Workbook 'master workbook
Dim aWS As Worksheet 'active sheet in master workbook
Dim RowCount As Long 'Rows used on master sheet
Dim uRange As Range 'usedrange for each temporary sheet

'***** Set folder to cycle through *****
Path = ThisWorkbook.Path & "\subdirectory\" 'Change as needed, ie "C:\"

Application.EnableEvents = False 'turn off events
Application.ScreenUpdating = False 'turn off screen updating
Set mWB = Workbooks.Add(1) 'create a new one-worksheet workbook
Set aWS = mWB.ActiveSheet 'set active sheet variable to only sheet in mWB
If Right(Path, 1) <> Application.PathSeparator Then 'if path doesnt end in "\"
Path = Path & Application.PathSeparator 'add "\"
End If
FileName = Dir(Path & "*.xls", vbNormal) 'set first file's name to filename variable
Do Until FileName = "" 'loop until all files have been parsed
If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
For Each tWS In tWB.Worksheets 'loop through each sheet
Set uRange = tWS.Range("A2", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
.Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1)) 'set used range
If RowCount + uRange.Rows.Count > 65536 Then 'if the used range wont fit on the sheet
aWS.Columns.AutoFit 'autofit mostly-used worksheet's columns
Set aWS = mWB.Sheets.Add(After:=aWS) 'add a new sheet that will accommodate data
RowCount = 0 'reset RowCount variable
End If
If RowCount = 0 Then 'if working with a new sheet
aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value 'copy headers from tWS

'Copy Formats
tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Copy
aWS.Range("A1").PasteSpecial xlPasteFormats
'@@@@@@@@@@@@@@@@@@@@@@@@@

RowCount = 1 'add one to rowcount
End If
aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
= uRange.Value 'move data from temp sheet to data sheet

'CopyFormats
uRange.Copy
aWS.Range("A" & RowCount + 1).PasteSpecial (xlPasteFormats)
'@@@@@@@@@@@@@@@@@@@@@@@@@@


RowCount = RowCount + uRange.Rows.Count 'increase rowcount accordingly
Next 'tWS
tWB.Close False 'close temporary workbook without saving
End If
FileName = Dir() 'set next file's name to FileName variable
Loop
aWS.Columns.AutoFit 'autofit columns on last data sheet
mWB.Sheets(1).Select 'select first data sheet on master workbook
Application.EnableEvents = True 're-enable events
Application.ScreenUpdating = True 'turn screen updating back on

'Clear memory of the object variables
Set tWB = Nothing
Set tWS = Nothing
Set mWB = Nothing
Set aWS = Nothing
Set uRange = Nothing
End Sub

[ChrisL]

@mdmackillop: yes sir, that's the code. Thanx! I will try your variation once I get to my desk at university:) Hope it works.

@monarchd: thanx for the advice! However, as you can see in the script mdmackillop posted there is no 'copy' in the original script. I will try if the tool you posted works though.

Will let you guys know if it worked!

[ChrisL]

@mdmackillop: the script does exactly what I wanted. Thanx! However, I just noted it automatically changes some collumns with text into numbers. So for example it turns both the texts '003' and '03' into the number '3'. So what I was adding a line which turns the script into:
Option Explicit

Sub CombineSheetsFromAllFilesInADirectory()

Dim Path As String 'string variable to hold the path to look through
Dim FileName As String 'temporary filename string variable
Dim tWB As Workbook 'temporary workbook (each in directory)
Dim tWS As Worksheet 'temporary worksheet variable
Dim mWB As Workbook 'master workbook
Dim aWS As Worksheet 'active sheet in master workbook
Dim RowCount As Long 'Rows used on master sheet
Dim uRange As Range 'usedrange for each temporary sheet

'***** Set folder to cycle through *****
Path = ThisWorkbook.Path & "\subdirectory\" 'Change as needed, ie "C:\"

Application.EnableEvents = False 'turn off events
Application.ScreenUpdating = False 'turn off screen updating
Set mWB = Workbooks.Add(1) 'create a new one-worksheet workbook
Set aWS = mWB.ActiveSheet 'set active sheet variable to only sheet in mWB
If Right(Path, 1) <> Application.PathSeparator Then 'if path doesnt end in "\"
Path = Path & Application.PathSeparator 'add "\"
End If
FileName = Dir(Path & "*.xls", vbNormal) 'set first file's name to filename variable
Do Until FileName = "" 'loop until all files have been parsed
If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
For Each tWS In tWB.Worksheets 'loop through each sheet
Set uRange = tWS.Range("A2", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
.Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1)) 'set used range
If RowCount + uRange.Rows.Count > 65536 Then 'if the used range wont fit on the sheet
aWS.Columns.AutoFit 'autofit mostly-used worksheet's columns
Set aWS = mWB.Sheets.Add(After:=aWS) 'add a new sheet that will accommodate data
RowCount = 0 'reset RowCount variable
End If
If RowCount = 0 Then 'if working with a new sheet
aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value 'copy headers from tWS

'Copy Formats
tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Copy
aWS.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
aWS.Range("A1").PasteSpecial xlPasteFormats
'@@@@@@@@@@@@@@@@@@@@@@@@@

RowCount = 1 'add one to rowcount
End If
aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
= uRange.Value 'move data from temp sheet to data sheet

'CopyFormats
uRange.Copy
aWS.Range("A" & RowCount + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
aWS.Range("A" & RowCount + 1).PasteSpecial (xlPasteFormats)
'@@@@@@@@@@@@@@@@@@@@@@@@@@


RowCount = RowCount + uRange.Rows.Count 'increase rowcount accordingly
Next 'tWS
tWB.Close False 'close temporary workbook without saving
End If
FileName = Dir() 'set next file's name to FileName variable
Loop
aWS.Columns.AutoFit 'autofit columns on last data sheet
mWB.Sheets(1).Select 'select first data sheet on master workbook
Application.EnableEvents = True 're-enable events
Application.ScreenUpdating = True 'turn screen updating back on

'Clear memory of the object variables
Set tWB = Nothing
Set tWS = Nothing
Set mWB = Nothing
Set aWS = Nothing
Set uRange = Nothing
End Sub

I'm a total scripting-noob, but I assume this is correct. It does give me the right result:)

@monarchd: the tool works more or less, but it copy's the headers and e lot of empty lines too and that gives me extra work.

[mdmackillop]

I'm a total scripting-noob, but I assume this is correct. It does give me the right result:)

That's what counts!