I have 88 files that contain the same number of columns (without column
headings) and I need to combine them into one consolidated file.
Please advise.
I have 88 files that contain the same number of columns (without column
headings) and I need to combine them into one consolidated file.
Please advise.
Not the answer to your prayers but this code does the sort of thing you want
to do:
You'll need to adjust it but the comments try to explain what's going on and
why. Hope it helps.
Regards
Trevor
Option Explicit
'
================================================================================
Sub Get_IDandV_Data()
Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objSubfolder As Scripting.Folder
Dim objFile As Scripting.File
Dim iRow As Long
Dim IDV_Folder As String
Dim CopyBook As Workbook
Dim TargetRange As Range
Dim mLastRow As Long
' locate the folder where the ID&V data files are stored
' for this code to work, they must be in the same folder as This Workbook
IDV_Folder = ActiveWorkbook.Path
' switch Screen Updating off to make processing faster
Application.ScreenUpdating = False
' switch Calculation off to make processing faster
Application.Calculation = xlCalculationManual
' create a link to the ID&V folder using the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(IDV_Folder)
' process each file in the ID&V folder
For Each objFile In objFolder.Files
' check it is an Excel workbook
If objFile.Type = "Microsoft Excel Worksheet" Then
' and that it is *not* This Workbook
If objFile.Name <> ThisWorkbook.Name Then
' create a reference to the workbook being processed
Set CopyBook = Workbooks.Open _
(Filename:=objFolder.Path & "\" &
objFile.Name)
' copy all the rows in the workbook being processed
CopyBook.Sheets("Sheet1").UsedRange.Copy
' activate This Workbook
ThisWorkbook.Activate
' and copy the data to the next available/blank row
With Sheets("List")
mLastRow =
WorksheetFunction.Max(Range("A65536").End(xlUp).Row, _
Range("B65536").End(xlUp).Row,
_
Range("C65536").End(xlUp).Row,
_
Range("D65536").End(xlUp).Row,
_
Range("E65536").End(xlUp).Row,
_
Range("F65536").End(xlUp).Row)
Set TargetRange = .Range("A" & mLastRow + 1)
TargetRange.Offset(0, 5).Value = CopyBook.Name
TargetRange.Select
.Paste
' clear the dancing ants and the clipboard
Application.CutCopyMode = False
End With
' close the workbook being processed without saving it
CopyBook.Close savechanges:=False
End If
End If
Next
' switch Calculation back on so the formulae will calculate properly
Application.Calculation = xlCalculationAutomatic
mLastRow = WorksheetFunction.Max(Range("A65536").End(xlUp).Row, _
Range("B65536").End(xlUp).Row, _
Range("C65536").End(xlUp).Row, _
Range("D65536").End(xlUp).Row, _
Range("E65536").End(xlUp).Row, _
Range("F65536").End(xlUp).Row)
' copy the workbook names down for cross referencing, if necessary
With Range("G2")
.FormulaR1C1 = "=IF(RC[-1]<>"""",RC[-1],R[-1]C)"
.AutoFill Destination:=Range("G2:G" & mLastRow)
End With
' convert to values to "fix" the file name
With Range("G2:G" & mLastRow)
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
' clear the dancing ants and the clipboard
Application.CutCopyMode = False
' insert the Row number so that the original sequence can be restored, if
necessary
With Range("H2")
.FormulaR1C1 = "=ROW()"
.AutoFill Destination:=Range("H2:H" & mLastRow)
End With
' convert to values to "fix" the row
With Range("H2:H" & mLastRow)
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
' clear the dancing ants and the clipboard
Application.CutCopyMode = False
With Cells
' remove the borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
' remove "patterns"
.Interior.ColorIndex = xlNone
' align the data left and top, no wrap
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
' finally, sort the data into Status, Surname, First name
.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlAscending, _
Key3:=Range("D2"), Order3:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
' switch Screen Updating back on to display the end result
Application.ScreenUpdating = True
' job done ...
End Sub
'
================================================================================
<[email protected]> wrote in message
news:[email protected]...
>I have 88 files that contain the same number of columns (without column
> headings) and I need to combine them into one consolidated file.
>
> Please advise.
>
Thank you so much, Mr. Shuttleworth for the code. I'll will give it a
try.
Trevor Shuttleworth wrote:
> Not the answer to your prayers but this code does the sort of thing you want
> to do:
>
> You'll need to adjust it but the comments try to explain what's going on and
> why. Hope it helps.
>
> Regards
>
> Trevor
>
>
> Option Explicit
> '
> ================================================================================
>
> Sub Get_IDandV_Data()
>
> Dim objFSO As Scripting.FileSystemObject
> Dim objFolder As Scripting.Folder
> Dim objSubfolder As Scripting.Folder
> Dim objFile As Scripting.File
> Dim iRow As Long
> Dim IDV_Folder As String
> Dim CopyBook As Workbook
> Dim TargetRange As Range
> Dim mLastRow As Long
>
> ' locate the folder where the ID&V data files are stored
> ' for this code to work, they must be in the same folder as This Workbook
> IDV_Folder = ActiveWorkbook.Path
>
> ' switch Screen Updating off to make processing faster
> Application.ScreenUpdating = False
> ' switch Calculation off to make processing faster
> Application.Calculation = xlCalculationManual
>
> ' create a link to the ID&V folder using the File System Object
> Set objFSO = CreateObject("Scripting.FileSystemObject")
> Set objFolder = objFSO.GetFolder(IDV_Folder)
>
> ' process each file in the ID&V folder
> For Each objFile In objFolder.Files
> ' check it is an Excel workbook
> If objFile.Type = "Microsoft Excel Worksheet" Then
> ' and that it is *not* This Workbook
> If objFile.Name <> ThisWorkbook.Name Then
> ' create a reference to the workbook being processed
> Set CopyBook = Workbooks.Open _
> (Filename:=objFolder.Path & "\" &
> objFile.Name)
> ' copy all the rows in the workbook being processed
> CopyBook.Sheets("Sheet1").UsedRange.Copy
> ' activate This Workbook
> ThisWorkbook.Activate
> ' and copy the data to the next available/blank row
> With Sheets("List")
> mLastRow =
> WorksheetFunction.Max(Range("A65536").End(xlUp).Row, _
> Range("B65536").End(xlUp).Row,
> _
> Range("C65536").End(xlUp).Row,
> _
> Range("D65536").End(xlUp).Row,
> _
> Range("E65536").End(xlUp).Row,
> _
> Range("F65536").End(xlUp).Row)
>
> Set TargetRange = .Range("A" & mLastRow + 1)
> TargetRange.Offset(0, 5).Value = CopyBook.Name
> TargetRange.Select
> .Paste
> ' clear the dancing ants and the clipboard
> Application.CutCopyMode = False
> End With
> ' close the workbook being processed without saving it
> CopyBook.Close savechanges:=False
> End If
> End If
> Next
>
> ' switch Calculation back on so the formulae will calculate properly
> Application.Calculation = xlCalculationAutomatic
>
> mLastRow = WorksheetFunction.Max(Range("A65536").End(xlUp).Row, _
> Range("B65536").End(xlUp).Row, _
> Range("C65536").End(xlUp).Row, _
> Range("D65536").End(xlUp).Row, _
> Range("E65536").End(xlUp).Row, _
> Range("F65536").End(xlUp).Row)
>
> ' copy the workbook names down for cross referencing, if necessary
> With Range("G2")
> .FormulaR1C1 = "=IF(RC[-1]<>"""",RC[-1],R[-1]C)"
> .AutoFill Destination:=Range("G2:G" & mLastRow)
> End With
> ' convert to values to "fix" the file name
> With Range("G2:G" & mLastRow)
> .Copy
> .PasteSpecial Paste:=xlPasteValues
> End With
> ' clear the dancing ants and the clipboard
> Application.CutCopyMode = False
>
> ' insert the Row number so that the original sequence can be restored, if
> necessary
> With Range("H2")
> .FormulaR1C1 = "=ROW()"
> .AutoFill Destination:=Range("H2:H" & mLastRow)
> End With
> ' convert to values to "fix" the row
> With Range("H2:H" & mLastRow)
> .Copy
> .PasteSpecial Paste:=xlPasteValues
> End With
> ' clear the dancing ants and the clipboard
> Application.CutCopyMode = False
>
> With Cells
> ' remove the borders
> .Borders(xlDiagonalDown).LineStyle = xlNone
> .Borders(xlDiagonalUp).LineStyle = xlNone
> .Borders(xlEdgeLeft).LineStyle = xlNone
> .Borders(xlEdgeTop).LineStyle = xlNone
> .Borders(xlEdgeBottom).LineStyle = xlNone
> .Borders(xlEdgeRight).LineStyle = xlNone
> .Borders(xlInsideVertical).LineStyle = xlNone
> .Borders(xlInsideHorizontal).LineStyle = xlNone
> ' remove "patterns"
> .Interior.ColorIndex = xlNone
> ' align the data left and top, no wrap
> .HorizontalAlignment = xlGeneral
> .VerticalAlignment = xlTop
> .WrapText = False
>
> ' finally, sort the data into Status, Surname, First name
> .Sort Key1:=Range("A2"), Order1:=xlAscending, _
> Key2:=Range("C2"), Order2:=xlAscending, _
> Key3:=Range("D2"), Order3:=xlAscending, _
> Header:=xlYes, _
> OrderCustom:=1, _
> MatchCase:=False, _
> Orientation:=xlTopToBottom
> End With
>
> ' switch Screen Updating back on to display the end result
> Application.ScreenUpdating = True
>
> ' job done ...
>
> End Sub
>
> '
> ================================================================================
>
> <[email protected]> wrote in message
> news:[email protected]...
> >I have 88 files that contain the same number of columns (without column
> > headings) and I need to combine them into one consolidated file.
> >
> > Please advise.
> >
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks