D
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
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