Results 1 to 5 of 5
  1. #1
    New Lounger
    Join Date
    Mar 2015
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Output in current workbook instead of a new workbook.

    I'm in the position of having a merge macro - very very close - to what I'm looking for. The principle problem is however that the consolidation output is created in a new workbook instead of being fed into the current workbook where the code is run, which is what I'm looking for. So how can the following code be modified?

    In advanced, thank you very much for the tip'n'help.

    Sub MergeAllWorkbooks()
    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

    ' Change this to the path\folder location of your files.
    MyPath = "C:\Users\Ron\test"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
    End If

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

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

    ' Set various application properties.
    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 = 1

    ' Loop through all files in the myFiles array.
    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

    ' Change this range to fit your own needs.
    With mybook.Worksheets(1)
    Set sourceRange = .Range("A1:C1")
    End With

    If Err.Number > 0 Then
    Err.Clear
    Set sourceRange = Nothing
    Else
    ' If source range uses 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 "There are not enough rows in the target worksheet."
    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 destination range.
    Set destrange = BaseWks.Range("B" & rnum)

    ' Copy the values from the source range
    ' to the destination range.
    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 the application properties.
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
    End With
    End Sub

  2. #2
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    Replace:
    Code:
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    with this:
    Code:
    Set BaseWks = ThisWorkbook.Worksheets.Add
    Regards,
    Rory

    Microsoft MVP - Excel

  3. The Following User Says Thank You to rory For This Useful Post:

    V.W.Birgisson (2015-03-11)

  4. #3
    New Lounger
    Join Date
    Mar 2015
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Thanks, rory - worked brilliant.

  5. #4
    New Lounger
    Join Date
    Mar 2015
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts
    One question more, what would the change to the "Set BaseWks" be, should I want the data to show in my current sheet, instead of there coming a new one?

  6. #5
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    Just:
    Code:
    Set BaseWks = ActiveSheet
    Regards,
    Rory

    Microsoft MVP - Excel

Tags for this Thread

Posting Permissions

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