Results 1 to 6 of 6
  1. #1
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts

    Merge excel documents inside a folder

    Dear Experts,
    I need to merge related excel documents into one document and give the name for the document.
    I am having 100 over excel files with different names in the folder and two(or more) documents may be related.

    Example: First Doc: Citi_account.xls
    Second Doc: Citi_server.xls

    I need to check the document name that appears before the underscore. If they are same, then create a new Doc(Citi.xls)
    with two worksheets. First worksheet(name shud be Account) refers to to Citi_account.xls and the second worksheet(name shud be Server)refers to Citi_server.xls
    Once related dcouments are merged then msgbox with no. of documents created.

    <code>
    Sub document_merge()
    Dim fldName As String
    Dim sFName As String
    fldName = BrowseForFolder("Select the folder")
    i = 0
    sFName = Dir(fldName)
    Do While Len(sFName) > 0
    ..............
    .............
    ...............
    end Sub
    'from www.gmayor.com
    Public Function BrowseForFolder(Optional strTitle As String) As String
    'strTitle is the title of the dialog box
    Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
    .Title = strTitle
    .AllowMultiSelect = False
    .InitialView = msoFileDialogViewList
    If .Show <> -1 Then GoTo err_Handler:
    BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
    End With
    lbl_Exit:
    Exit Function
    err_Handler:
    BrowseForFolder = vbNullString
    Resume lbl_Exit
    End Function

    </code>


    Can please help on how to check the filename and how to create a new document and paste the details.
    Appreciate sharing codes//
    Last edited by rajsarv14; 2016-07-25 at 04:04. Reason: Added request

  2. #2
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,633
    Thanks
    115
    Thanked 647 Times in 590 Posts
    Rajsarv,

    Here is the code that will do what you are requesting. By clicking on the "Create Files" button, the code will prompt you to navigate to the folder that has the files you want to extract.

    MergeDocuments1.png

    The code will pull the names of the files, paths into the spreadsheet then match up the files to determine the Document Prefix used for the name of the new file(s) and the sheet names that will be created within it. The code then creates the new file (.xls) and copies the first sheet from the source files into it.

    The folder can contain any types of files as the code will filter only the .xls, .xlsx, .xlsm file(s) to extract. This can easily be adjusted for just .xls if desired. There is no limit to the number within each grouping nor to the number of files created but it will influence the length of time needed to complete the task. When finished, a message box will indicate how many new files were created while column E indicates where they were created (which will be in the same selected folder).

    Remember during your testing to delete the created files prior to re-running the code or you will be prompted to over-write them. The workbook was created in 2010 but saved as an .xls file to match the file type of your source files.

    MergeDocuments2.png

    HTH,
    Maud

    Code:
    Public Sub ListFiles()
        Application.DisplayAlerts = False
        On Error Resume Next
    '--------------------------------------------
    'DECLARE AND SET VARIABLES
        Dim NewWb As Workbook, SrcWb As Workbook, SrcWs As Worksheet
        Dim wscount As Integer, num As Integer
        Dim ShellApplication As Object
        Set ShellApplication = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
        Path = ShellApplication.self.Path
        Set ShellApplication = Nothing
        Filename = Dir(Path & "\*.*")
    '--------------------------------------------
    'GET EXCEL FILENAMES AND LIST ON CURRENT WORKSHEET
        LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Do While Len(Filename) > 0
            s = Split(Filename, ".")
            ext = UCase(s(UBound(s)))
            If ext = "XSL" Or ext = "XLSX" Or ext = "XLSM" Then
                Cells(LastRow, 1).Value = Filename
    '--------------------------------------------
    'GET DOCUMENT PREFIX AND SHEET NAME
                If InStr(1, Cells(LastRow, 1), "_", vbTextCompare) > 0 Then
                    Cells(LastRow, 2) = Path
                    t = Split(Filename, "_")
                    Cells(LastRow, 3) = t(0)
                    u = Split(t(1), ".")
                    Cells(LastRow, 4) = u(0)
                    LastRow = LastRow + 1
                End If
            End If
            Filename = Dir
        Loop
    '--------------------------------------------
    'SORT ACCORDING TO DOCUMENT PREFIX
        LastRow = LastRow - 1
        srtrng = Range("A1:C" & LastRow)
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A" & LastRow) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange Range("A1:C" & LastRow)
            .Header = xlYes
            .Apply
        End With
    On Error GoTo 0
    '--------------------------------------------
    'DETERMINE FILES TO BE CREATED
        Match = 0
        Row = 2
        For I = 2 To LastRow - 1
            For J = I + 1 To LastRow
                If Cells(I, 3) = Cells(J, 3) Then
                    Cells(I, 5) = Path & "\" & Cells(I, 3) & ".xls"
                    Row = J
                    Match = 1
                End If
            Next J
            If Match = 1 Then I = Row
            Match = 0
        Next I
    '--------------------------------------------
    'CREATE NEW DOCUMENTS
        Application.ScreenUpdating = False
        num = 0
        For I = 2 To LastRow
            With ThisWorkbook.Worksheets(1)
            If .Cells(I, 5) <> "" Then
                Set NewWb = Workbooks.Add(1)
                NewWb.SaveAs Filename:=.Cells(I, 5), FileFormat:=xlExcel8
                num = num + 1
                wscount = 0
                For J = I To LastRow
                    If .Cells(I, 3) = .Cells(J, 3) Then
                        Set SrcWb = Workbooks.Open(Filename:=.Cells(J, 2) & "\" & .Cells(J, 1))
                        Set SrcWs = SrcWb.Worksheets(1)
                        SrcWs.Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
                        NewWb.Worksheets(NewWb.Worksheets.Count).Name = .Cells(J, 4)
                        If wscount = 0 Then
                            NewWb.Worksheets(1).Delete
                            wscount = 1
                        End If
                        SrcWb.Close False
                    End If
                Next J
                NewWb.Close True
            End If
            End With
        Next I
        MsgBox num & " files have been created"
    '--------------------------------------------
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End Sub
    
    
    Public Sub Reset()
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Range("A2:E" & LastRow).ClearContents
    End Sub
    Attached Files Attached Files

  3. #3
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Thank you very much for your time in helping me.
    I downloaded the attached excel and tried with 2 excel files inside a folder.
    Once I click the create sheet, it immediately pops-out message 0 files created and then the processing circle keeps rolling and never exits.
    Am I doing it correctly or something needs to be adjusted. Please advise.

  4. #4
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,633
    Thanks
    115
    Thanked 647 Times in 590 Posts
    rajsarv,

    A typo made the code look for .xsl instead of .xls. It has been fixed in the attached spreadsheet. Let me know if this meets your needs.

    Maud
    Attached Files Attached Files

  5. The Following User Says Thank You to Maudibe For This Useful Post:

    rajsarv14 (2016-09-04)

  6. #5
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Maud,
    It's great and awesome. Your explanations are wonderful to understand the code.
    Many thanks for your time.

  7. #6
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,633
    Thanks
    115
    Thanked 647 Times in 590 Posts
    Thanks for the thanks Rajsarv.

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
  •