Copy Data where Source Workbook contains Name that is in destination sheet

[howard]

I have tried to write code to copy the entire range from sheet "Journals" in the source file and paste as values in destination sheet , where the names are similar for eg source file name is BR1 Southern (BTR) Tax Journals.xlsx . The Destination sheet for eg is "BR1 Southern" so there is a partial match between the destination sheet and source file , so the data must be pasted into this sheet

I have several source file where the names are similar to the destination sheet and they must copied using the same criteria

I cannot get the data to paste on the appropriate sheets

The folder is C:\Tax Journals & Computations Year End

Kindly amend my Code

 Sub CopyJournalDataToMatchingSheets()
    Dim fd As FileDialog
    Dim FilePath As String
    Dim SourceWorkbook As Workbook
    Dim DestinationWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim DestinationSheet As Worksheet
    Dim SourceFileName As String
    Dim CleanFileName As String
    Dim DestinationSheetName As String
    Dim LastRow As Long
    Dim i As Integer
    Dim SourceFileNamePart As String

    ' Set the destination workbook
    Set DestinationWorkbook = ThisWorkbook

    ' Initialize FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Select Files from Tax Journals Folder"
        .InitialFileName = "C:\Tax Journals & Computations Year End\"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
        .AllowMultiSelect = True

        ' Show dialog and exit if canceled
        If .Show = False Then
            MsgBox "No files selected. Exiting macro.", vbExclamation
            Exit Sub
        End If
    End With

    ' Loop through each selected file
    For i = 1 To fd.SelectedItems.Count
        FilePath = fd.SelectedItems(i)

        ' Open the source workbook
        On Error Resume Next
        Set SourceWorkbook = Workbooks.Open(FilePath, ReadOnly:=False)
        If Err.Number <> 0 Then
            MsgBox "Could not open file: " & FilePath, vbExclamation
            Err.Clear
            On Error GoTo 0
            GoTo NextFile
        End If
        On Error GoTo 0

        ' Extract the source file name (without extension)
        SourceFileName = Replace(Dir(FilePath), ".xlsx", "")
        SourceFileName = Replace(SourceFileName, ".xlsm", "")
        SourceFileName = Replace(SourceFileName, ".xls", "")
        SourceFileName = Trim(SourceFileName)

        ' Remove any text within parentheses and the parentheses themselves
        If InStr(SourceFileName, "(") > 0 Then
            CleanFileName = Trim(Replace(SourceFileName, Mid(SourceFileName, InStr(SourceFileName, "("), InStr(SourceFileName, ")") - InStr(SourceFileName, "(") + 1), ""))
        Else
            CleanFileName = SourceFileName
        End If

        ' Use the clean part of the file name as the matching string
        SourceFileNamePart = CleanFileName

        ' Check if the source sheet "Journals" exists
        On Error Resume Next
        Set SourceSheet = SourceWorkbook.Sheets("Journals")
        On Error GoTo 0

        If Not SourceSheet Is Nothing Then
            ' Look for a destination sheet that partially matches the source file name part
            For Each DestinationSheet In DestinationWorkbook.Sheets
                DestinationSheetName = DestinationSheet.Name

                ' Check if the destination sheet name contains the source filename part
                If InStr(1, DestinationSheetName, SourceFileNamePart, vbTextCompare) > 0 Then

                    ' Copy data from the source sheet "Journals"
                    With SourceSheet
                        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                        If LastRow > 0 Then
                            .Range("A1:A" & LastRow).EntireRow.Copy
                        End If
                    End With

                    ' Paste data into the destination sheet starting at A1
                    With DestinationSheet
                        .Cells.Clear ' Optional: Clear existing data before pasting
                        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        .Range("A1").PasteSpecial Paste:=xlPasteFormats
                    End With

                    Exit For ' Exit the loop once the matching sheet is found
                End If
            Next DestinationSheet
        Else
            MsgBox "Source sheet 'Journals' not found in: " & FilePath, vbExclamation
        End If

        ' Close the source workbook without saving
        SourceWorkbook.Close SaveChanges:=False

NextFile:
    Next i

    ' Clean up
    Application.CutCopyMode = False
    MsgBox "Data copied successfully.", vbInformation
End Sub [code]

 

[Alex Blakenburg]

Did it work on any sheets ?
Give us some examples of where it didn't work.

You have only provided the one example and based on that you could have used:

If InStr(1, FilePath, DestinationSheetName, vbTextCompare) > 0 Then

Is there a reason for not using that ?

 

[howard]

Thanks Alex

I made a number of changes and code works perfectly

 Sub CopyJournalDataToMatchingSheets()
    Dim fd As FileDialog
    Dim FilePath As String
    Dim SourceWorkbook As Workbook
    Dim DestinationWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim DestinationSheet As Worksheet
    Dim SourceFileName As String
    Dim DestinationSheetName As String
    Dim LastRow As Long, LastCol As Long
    Dim i As Integer

    ' Set the destination workbook
    Set DestinationWorkbook = ThisWorkbook

    ' Initialize FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Select Files from Tax Journals Folder"
        .InitialFileName = "C:\Tax Journals & Computations Year End\"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
        .AllowMultiSelect = True

        ' Show dialog and exit if canceled
        If .Show = False Then
            MsgBox "No files selected. Exiting macro.", vbExclamation
            Exit Sub
        End If
    End With

    ' Loop through each selected file
    For i = 1 To fd.SelectedItems.Count
        FilePath = fd.SelectedItems(i)

        ' Open the source workbook
        On Error Resume Next
        Set SourceWorkbook = Workbooks.Open(FilePath, ReadOnly:=False)
        If Err.Number <> 0 Then
            MsgBox "Could not open file: " & FilePath, vbExclamation
            Err.Clear
            On Error GoTo 0
            GoTo NextFile
        End If
        On Error GoTo 0

        ' Extract the source file name without extension
        SourceFileName = Replace(Dir(FilePath), ".xlsx", "")
        SourceFileName = Replace(SourceFileName, ".xlsm", "")
        SourceFileName = Replace(SourceFileName, ".xls", "")

        ' Check if the source sheet "Journals" exists
        On Error Resume Next
        Set SourceSheet = SourceWorkbook.Sheets("Journals")
        On Error GoTo 0

        If Not SourceSheet Is Nothing Then
            ' Ensure that SourceSheet is valid before accessing UsedRange
            If Not SourceSheet.UsedRange Is Nothing Then
                ' Get the last row and column with data in the source sheet
                With SourceSheet.UsedRange
                    LastRow = .Rows(.Rows.Count).Row
                    LastCol = .Columns(.Columns.Count).Column
                End With

                If LastRow > 0 And LastCol > 0 Then
                    ' Loop through destination sheets to find a match
                    For Each DestinationSheet In DestinationWorkbook.Sheets
                        DestinationSheetName = DestinationSheet.Name

                        ' Check if the destination sheet name is found in the source file name
                        If InStr(1, SourceFileName, DestinationSheetName, vbTextCompare) > 0 Then
                            ' Clear existing data in the destination sheet
                            DestinationSheet.Cells.Clear

                            ' Copy and paste values and formats
                            SourceSheet.Range(SourceSheet.Cells(1, 1), SourceSheet.Cells(LastRow, LastCol)).Copy
                            With DestinationSheet.Range("A1")
                                .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                                .PasteSpecial Paste:=xlPasteFormats
                            End With

                            Application.CutCopyMode = False ' Clear clipboard
                            
                            ' Check if A1 is not blank before autofitting
                            If DestinationSheet.Range("A1").Value <> "" Then
                                ' Autofit columns A to L if A1 is not blank
                                DestinationSheet.Columns("A:L").AutoFit
                            End If
                            
                            Exit For ' Exit the loop once the matching sheet is found
                        End If
                    Next DestinationSheet
                End If
            Else
                MsgBox "The UsedRange in 'Journals' sheet is invalid or empty in: " & FilePath, vbExclamation
            End If
        Else
            MsgBox "Source sheet 'Journals' not found in: " & FilePath, vbExclamation
        End If

        ' Clean up SourceSheet reference and close the source workbook
        Set SourceSheet = Nothing
        SourceWorkbook.Close SaveChanges:=False

NextFile:
    Next i

    ' Clean up
    Application.CutCopyMode = False
    MsgBox "Data copied successfully.", vbInformation
End Sub

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.
PS: Unless you are using SourceFileName somewhere else, you don't even need to worry about replacing the extension.

 

[howard]

Thanks for your input