Merge files if filenames match

[dapeamel]

Hi All,

I got a code that merge two excel files to into one file.
without save.

I select first with a dialogWindow a SourceFolder,
I select then a TargetFolder with another dialogWindow.

I want instead of have two dialogwindows use One, to loop through a whole folder.

the filenames in the folder have this pattern see below:
but the names can be almost anything, there is one thing that make them as a pair.


Se follow Filenames so see the pattern:

TEST_Translation2_jeeves_sv.xls
TEST_Translation2_jeeves_sv_NoTrans.xls

TEST_Translation2_UCHPResourcesCommon_de.xls
TEST_Translation2_UCHPResourcesCommon_de_NoTrans.x ls


TEST_Translation2_creditDocument_ar.xls


TEST_Translation2_creditDocument_ar_NoTrans.xls

if the select the first file of the examples:

I want now to merge the sheet from "TEST_Translation2_jeeves_sv_NoTrans.xls" to "TEST_Translation2_jeeves_sv.xls" and save the file (TEST_Translation2_jeeves_sv.xls)

the script need to loop through a whole folder.

Could someone help me to modify my code?

Sub Combinles_Step1()
'Declare Variables
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String
    
    
    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .AllowMultiSelect = False
        .Title = "Select Source folder"
        If .Show = -1 Then
        
            Application.DisplayAlerts = False
            Application.EnableEvents = False
            Application.ScreenUpdating = False
        
            FolderLocation = .SelectedItems(1)
            


            
            'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
            SelectedFiles = Application.GetOpenFilename( _
                filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
            
            'Create a new workbook
            Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
            strFilename = Dir(FolderLocation & "\*.xls", vbNormal)
            
            'Iterate for each file in folder
            If Len(strFilename) = 0 Then Exit Sub
            
            
            Do Until strFilename = ""
                
                    Set WorkbookSource = Workbooks.Open(Filename:=FolderLocation & "\" & strFilename)
                    Set WorksheetSource = WorkbookSource.Worksheets(1)
                    WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
                    WorkbookSource.Close False
                strFilename = Dir()
                
            Loop
            WorkbookDestination.Worksheets(1).Delete
            
            Application.DisplayAlerts = True
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End With
End Sub

Thank you in advance