Trevor said: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
'
================================================================================
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.
Want to reply to this thread or ask your own question?
You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.