Consolidate Workbooks with Single header Row

[DavidH56]

Hi,

I'm currently using Ron Debruin's code to consolidate workbooks. I'm having
difficulty with trying to elminate extra row headers which are in row 1. I'd
like the final workbook to only have one row header instead of several. All
row headers are alike. Any assistance that anyone can provide would be
greatly appreciated. Please see my code here:

Sub GetData_FromFiles()
'Copy cells from folder and subfolder(s)
Dim Subfolders As Boolean
Dim Fsbj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
Dim RootPath, FilesInPath As String
Dim sh As Worksheet, destrange As Range
Dim rnum As Long
Dim MyFiles() As String
Dim Fnum As Long
Dim FileExt As String
Dim myWorkbook As Workbook
Dim rng As Range
Dim Rwcount As Long

Set myWorkbook = Workbooks.Add(1) 'single sheet, same as xlwbatworksheet

'myWorkbook.Worksheets(1).Name = "DeleteMeLater"

'Loop through all files in the Root folder
RootPath = "c:\Temp\Reports" ' <<<< Change"

'Loop through the subfolders True or False
Subfolders = True

'Loop through files with this extension (*.xl* is all Excel files)
FileExt = "*.xl*"

'Add a slash at the end if the user forget it
If Right(RootPath, 1) <> "\" Then
RootPath = RootPath & "\"
End If

Set Fsbj = CreateObject("Scripting.FileSystemObject")
If Not Fsbj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If

Set RootFolder = Fsbj.GetFolder(RootPath)

'Fill the array(myFiles)with the list of Excel files in the folder(s)
Erase MyFiles()
Fnum = 0

'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file

'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders Then
Call ListFilesInSubfolders(OfFolder:=RootFolder)
End If

' Now we can loop through the files in the array MyFiles to get the cell
values
'******************************************************************

'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mmm-yy hhnn") & "hrs"

If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")

' Copy the workbook name in Column E
'sh.Cells(rnum + 1, "E").Value = MyFiles(Fnum)

'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyFiles(Fnum), "RDU", "A:Q", destrange, False, False

Next
End If

'Sort By Job Order then RDU
Cells.Select
Selection.Sort Key1:=Range("F1"), Order1:=xlAscending, Key2:=Range("L1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2 _
:=xlSortNormal

Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

'' The following commands assign a line item number to each row of data
where there
' are no blank rows in the data area and each row only contains one
complete data
' record. This also assumes the top row consists of column headings.
Range("B1").Select
Selection.End(xlDown).Select
MyLastRow = ActiveCell.Row
Range("A1").Select
ActiveCell.FormulaR1C1 = "=ROW()-1"
Range("A1").Select
Selection.Copy
Range("A1:A" & MyLastRow).Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Copy
Range("A1").Select

'Format Cell Borders
Application.StatusBar = "Formatting Borders...."

Range("A1").CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select

Namefixer
TrimColF
'Name Ranges
CreateNames
FormatDateCols
AdjustColumnWidths
'Format Header Row
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
'Format Font
Range("A2:R2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
End With
Range("A2:R2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
FormatPageHeaderFooterA
Range("A1").Select
AddFormula
AutoFillMacro
SumFormula_InM
AlignHeaderRow
FinishHeader
FixColHandI
FormatCellBorders
FormatHeaderBorders
LockFormulaCells
TestReference
CreateEventProcedure
CloseVBEwindow
End Sub

Again thanks in advance.

 

[Ron de Bruin]

Hi David

On this page you can see how to change the startcell
http://www.rondebruin.nl/fso.htm

The only thing you must change is to copy the header one time
If you need help with that let me know



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[DavidH56]

Thanks for your response Ron. Yes, please assist me with copying the header
only once as you stated. I did review the page and looked at using the
"StartCell" & "SourceRange" but I'm not able to integrate this process into
my macro.

Thanks again.
--
By persisting in your path, though you forfeit the little, you gain the
great.

Hi David

On this page you can see how to change the startcell
http://www.rondebruin.nl/fso.htm

The only thing you must change is to copy the header one time
If you need help with that let me know



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[Ron de Bruin]

I will reply this evening with a example
Is subfolders important for you ?

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Thanks for your response Ron. Yes, please assist me with copying the header
only once as you stated. I did review the page and looked at using the
"StartCell" & "SourceRange" but I'm not able to integrate this process into
my macro.

Thanks again.

 

[DavidH56]

Thanks Ron. No there will be no subfolders involved.

 

[Ron de Bruin]

Try this one

Change
MyPath = "C:\Users\Ron\test"

It will copy the header cells A1:Z1 in this example


Sub Basic_Test()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim FirstCell As String

'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 2

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next
If Fnum = 1 Then
mybook.Worksheets(1).Range("A1:Z1").Copy BaseWks.Range("B1")
End If

With mybook.Worksheets(1)
FirstCell = "A2"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
'Test if the row of the last cell >= then the row of the FirstCell
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With

'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)

'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next Fnum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer

Select Case choice

Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0

End Select
End Function





--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[DavidH56]

Thanks Ron, this works just great.

 

[Ron de Bruin]

Thanks for the feedback

Have a nice weekend

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm