+ Reply to Thread
Results 1 to 2 of 2

Macro Code for copying separate worksheets into one combined worksheet works but...

Hybrid View

  1. #1
    Registered User
    Join Date
    03-01-2019
    Location
    WA
    MS-Off Ver
    2007
    Posts
    3

    Macro Code for copying separate worksheets into one combined worksheet works but...

    The following code works great until I figured out the last row in any of the worksheets isn't being copied.
    What I have is single invoices (separate workbooks ... only one per workbook) and am selecting the folder of all the workbooks and the code copies the contents and combines all in one sheet:
    Using office 2007

    (had help with the code so don't understand much of the workings other than it needs to include the last row of info)

    Option Explicit
    Public strPath As String
    Public Type SELECTINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
    
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                         Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                       Alias "SHBrowseForFolderA" (lpBrowseInfo As SELECTINFO) As Long
    Function SelectFolder(Optional Msg) As String
        Dim sInfo As SELECTINFO
        Dim path As String
        Dim r As Long, x As Long, pos As Integer
        sInfo.pidlRoot = 0&
        
        If IsMissing(Msg) Then
            sInfo.lpszTitle = "Select your folder."
        Else
            sInfo.lpszTitle = Msg
        End If
        
        sInfo.ulFlags = &H1
        
        x = SHBrowseForFolder(sInfo)
        
        path = Space$(512)
        r = SHGetPathFromIDList(ByVal x, ByVal path)
        If r Then
            pos = InStr(path, Chr$(0))
            SelectFolder = Left(path, pos - 1)
        Else
            SelectFolder = ""
        End If
    End Function
    'Merge all your excel files to a main file.
    Sub MergeExcels()
        Dim path As String, ThisWB As String, lngFilecounter As Long
        Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
        Dim Filename As String, Wkb As Workbook
        Dim CopyRng As Range, Dest As Range
        Dim RowofCopySheet As Integer
     
        RowofCopySheet = 1 ' Row Number from where you wish to start copying
     
        ThisWB = ActiveWorkbook.Name
     
        path = SelectFolder("Select a folder containing Excel files you want to merge")
     
        Application.EnableEvents = False
        Application.ScreenUpdating = False
     
        Set shtDest = ActiveWorkbook.Sheets(1)
        Filename = Dir(path & "\*.csv", vbNormal)
        If Len(Filename) = 0 Then Exit Sub
        Do Until Filename = vbNullString
            If Not Filename = ThisWB Then
                Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
                Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
                Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
                CopyRng.Copy Dest
                Wkb.Close False
            End If
     
            Filename = Dir()
        Loop
     
        Range("A1").Select
     
        Application.EnableEvents = True
        Application.ScreenUpdating = True
     
        MsgBox "Files Merged!"
    End Sub

  2. #2
    Forum Expert
    Join Date
    05-29-2020
    Location
    NH USA
    MS-Off Ver
    365
    Posts
    2,103

    Re: Macro Code for copying separate worksheets into one combined worksheet works but...

    Add the red section below


    If Len(Filename) = 0 Then Exit Sub
        Do Until Filename = vbNullString
            If Not Filename = ThisWB Then
                Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
                Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count + 1, ActiveSheet.UsedRange.Columns.Count))
                Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
                CopyRng.Copy Dest
                Wkb.Close False
            End If
     
            Filename = Dir()
        Loop

+ Reply to Thread

Thread Information

Users Browsing this Thread

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

Similar Threads

  1. [SOLVED] Automatically merge three tables on separate worksheets into one combined table
    By gjw1971 in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 07-05-2016, 06:31 PM
  2. Replies: 8
    Last Post: 04-15-2014, 04:35 AM
  3. Code fails when ran within Userform, but works when ran from Macro button on worksheet.
    By Nitefox in forum For Other Platforms(Mac, Google Docs, Mobile OS etc)
    Replies: 6
    Last Post: 11-29-2013, 02:28 AM
  4. Macro to Copy data from two separate worksheets and combine into a third worksheet
    By Excel-RZ in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 11-20-2013, 07:12 AM
  5. Macro for copying from separate worksheets to the mother worksheet
    By adinutzaa in forum Excel Programming / VBA / Macros
    Replies: 5
    Last Post: 08-23-2010, 05:12 PM
  6. Replies: 3
    Last Post: 02-18-2005, 10:06 AM
  7. [SOLVED] Copying Totals of separate worksheets to a single Summary Worksheet
    By buster1831 in forum Excel General
    Replies: 0
    Last Post: 02-18-2005, 10:06 AM

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