+ Reply to Thread
Results 1 to 3 of 3

Consolidation of Files

  1. #1

    Consolidation of Files

    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.


  2. #2
    Trevor Shuttleworth
    Guest

    Re: Consolidation of Files

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




  3. #3

    Re: Consolidation of Files

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



+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1