Solved: Merging sheets and stopping Excel from date formatting cells

[Garwalde]

I'm sorry if this issue has already been addressed, I've tried searching for a solution but have been unable to find one.

I'm forced to use Excel2000 and a very old Excel document with port allocations. The doc has about 40 sheets which I merge to one sheet to be able to save it all into a .csv file that I process for various purposes.

I'm using a script found on this site (not allowed to post links yet it seems) with a few tweaks:



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
Dim sheetDelimiter As String

sheetDelimiter = "######"
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 = 30
'Now retrieve headers, no copy&paste needed
With trg.Cells(3, 1).Resize(1, colCount)
.Value = sht.Cells(3, 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
'Delimits the copied sheets with a string in a new row
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(1, 1).Value = sheetDelimiter
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(4, 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

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


Now, the script merge the cells into one sheet and delimits the way I want it to. The problem I have is that some fields has values that looks like '0-19', '2-03' etc and Excel reformats it to dates when everything is merged into the master sheet.

As I understand it you can't turn the auto format/correction of for dates in any way, instead you have to play around with formatting the cells 'manually' before you copy/paste. It doesn't work setting the original cells to 'Text' before running the script and it doesn't work to set the cells in the master sheet to 'Text' after the script is run either cause the formatting is already done. So I'm guessing I have to format the columns in the master sheet before the pasting begins?

I would appreciate any help on this, thanks.

[Bob Phillips]

Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Long
Dim sheetDelimiter As String

sheetDelimiter = "######"
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

Application.ScreenUpdating = False

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

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

'Delimits the copied sheets with a string in a new row
trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 1).Value = sheetDelimiter
Set rng = sht.Range(sht.Cells(4, 1), sht.Cells(Rows.Count, 1).End(xlUp).Resize(, colCount))
rng.Copy trg.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next sht

Application.ScreenUpdating = True
End Sub

[Garwalde]

Many thanks mate, this will help me a lot :thumb

[mdmackillop]

Hi Garwalde,
Welcome to VBAX.
If this is solved, you can mark it so using the Thread Tools dropdown
Regards
MD

[Garwalde]

Aaah, thanks :yes