Concatenate excel files in one with seperate worksheets

[Dimitris]

Hi !

I want to concatenate excel files found in one directory
by having one Workbook with multiple worksheets named
after the files found. The problem is that I get different
colour after the concatenation on the fonts and the
backgrounds ! Any guess why ?

Thanks in advance


Option Explicit
Option Base 1
Private boolStatusBarState As Boolean
Private lngMsgboxAnswer As Long
Private intNumberOfFiles As Integer
Private intRealNumberOfFiles As Integer
Private intA As Integer
Private intB As Integer
Private strTemp As String
Dim strSheetNames() As String
Dim intDuplicateCount() As Integer

'This macro will grab the first sheet of every workbook it
finds in
'it's own folder, and create a consolidated workbook from
them
'This file works as either an XLS or an XLA workbook
'Of course, it SHOULD be an XLA add-in.

Public Sub Consolidate(DummyVariable As Boolean)

'Setting up!

With Application
.EnableCancelKey = xlDisabled
.EnableEvents = False
.DisplayAlerts = False
boolStatusBarState = .DisplayStatusBar
.DisplayStatusBar = True
.ScreenUpdating = False
End With

Dim ThisFile As Workbook
Set ThisFile = ThisWorkbook

'Let's start by looking to see if there are any .xls
workbooks
'in the same folder that this file resides in! (We'll also
'check any subfolders of this folders, why not?)
7
Application.StatusBar = "Searching for workbook files..."

Dim fs As FileSearch
Set fs = Application.FileSearch

With fs
.NewSearch
' .SearchSubFolders = True *** Marked out ***
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
' .LookIn = ThisWorkbook.Path
.LookIn = "d:\temp\"
.Filename = "*.xls"
.MatchTextExactly = True
intNumberOfFiles = .Execute(SortBy:=msoSortByFileName,
_
SortOrder:=msoSortOrderAscending)
End With

Application.StatusBar = False

'Let's be sure not to include THIS file in the list!

intRealNumberOfFiles = intNumberOfFiles

If intNumberOfFiles <> 0 Then
For intA = 1 To intNumberOfFiles
If fs.FoundFiles(intA) = ThisFile.FullName Then _
intRealNumberOfFiles = intNumberOfFiles - 1
Next intA
End If

'Abort the process if we find less than 2 files to
consolidate

'if intRealNumberOfFiles < 2 Then
' lngMsgboxAnswer = MsgBox(" Only " &
intRealNumberOfFiles & _
" file(s) found." & vbCrLf & "Terminating process.", _
vbExclamation + vbOKOnly, "Error")
'GoTo ShutDown
'End If

'At this point, we know that we have at least two files
that
'we can consolidate, so ask the user if he/she wants to
'continue.

'lngMsgboxAnswer = MsgBox("There are " &
intRealNumberOfFiles & _
" files to be processed." & vbCrLf & vbCrLf & "Continue?",
vbQuestion _
+ vbOKCancel + vbDefaultButton1, "Proceed")

'If lngMsgboxAnswer = vbCancel Then GoTo ShutDown

'The user said "Let's do it!"
'Let's check out the filenames

ReDim strSheetNames(intNumberOfFiles)
ReDim intDuplicateCount(intNumberOfFiles)

'First, let's populate a dynamic array with
'all of the filenames. We'll strip the pathnames
'from the name first, then the file
'extension (.xls), and then we'll truncate the
'name to a maximum of 27 characters

For intA = 1 To intNumberOfFiles
strTemp = FileNameOnly(fs.FoundFiles(intA))
If Len(strTemp) > 4 Then
If Mid(strTemp, Len(strTemp) - 3, 1) = "." Then _
strTemp = Left(strTemp, Len(strTemp) - 4)
End If
strSheetNames(intA) = Left(strTemp, 27)
intDuplicateCount(intA) = 0
Next intA

'Then we'll count up the duplicates

For intA = 2 To intNumberOfFiles
For intB = 1 To intA - 1
If strSheetNames(intB) = strSheetNames(intA) Then
If intDuplicateCount(intB) = 0 Then _
intDuplicateCount(intB) = 1
intDuplicateCount(intA) = intDuplicateCount
(intB) + 1
End If
Next intB
Next intA

'If there are any duplicate names, then we'll
'rename them here (in memory) so they don't have
'duplicate sheet names

For intA = 1 To intNumberOfFiles
If intDuplicateCount(intA) <> 0 Then
strSheetNames(intA) = strSheetNames(intA) & " " & _
Format(intDuplicateCount(intA), "000")
End If
Next intA

'Let's create the new workbook now!

Dim newBook As Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Dim FoundBook As Workbook

intB = 1
For intA = 1 To intNumberOfFiles
If fs.FoundFiles(intA) = ThisFile.FullName Then GoTo
Skip
Application.StatusBar = "Processing file #" & intB
Set FoundBook = Workbooks.Open(Filename:=fs.FoundFiles
(intA), _
ReadOnly:=True)
FoundBook.Worksheets(1).Copy after:=newBook.Worksheets
(intB)
newBook.Worksheets(intB + 1).Name = strSheetNames(intA)
FoundBook.Close SaveChanges:=False
intB = intB + 1
Skip:
Next intA

newBook.Worksheets(1).Delete '(The first page was blank)
'newBook.Worksheets(2).SetFocus

Dim strdate As String
strdate = Format(Now, "yyyymmdd")
newBook.SaveAs Filename:="d:\temp\new\" & strdate & ".xls"

ShutDown:

'And then let's shutdown the process nicely!

With Application
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = False
.DisplayStatusBar = boolStatusBarState
End With

ThisFile.Close SaveChanges:=False 'close THIS file (the
macro)

End Sub

Private Function FileNameOnly(pname) As String
' Returns the filename from a path/filename string
Dim i As Integer, length As Integer, temp As String
length = Len(pname)
temp = ""
For i = length To 1 Step -1
If Mid(pname, i, 1) = Application.PathSeparator Then
FileNameOnly = temp
Exit Function
End If
temp = Mid(pname, i, 1) & temp
Next i
FileNameOnly = pname
End Function

Private Sub Workbook_Open()
Consolidate (True)
End Sub

 

[Dave Peterson]

It looks like you're copying the existing sheet (including formats) with this
line:

FoundBook.Worksheets(1).Copy after:=newBook.Worksheets(intB)

Maybe you could apply the format you want after you do the copy:

with activesheet.cells 'the copied sheet is now active
.numberformat = "General"
.Font.ColorIndex = 0
.Interior.ColorIndex = xlNone
end with

Or maybe you could add a new worksheet and then copy the cells, but paste
special|formulas (or paste special values)????