Excel VBA. If worksheets in the current open workbook matches file names in a folder, transfer data.

[TheHack22]

Hi All,

I'm not sure if anyone can help me here. I have a weekly report and would usually use a VBA to break out the data per regions into separate worksheets. I would then manually match each worksheets name (Eg, Eastern, Southern, Canada, Gulf) to workbooks name in a folder, then manually copy and paste that the appropriate sheet.

I would like a VBA to say if the worksheet on the right, eg Canada matches a workbook named Canada, then copy and paste the sheet data on the right(Source) to workbook on left(Destination).

Is this possible? Thanks in advance for your help.
Imran

 

[Saurabhj]

Hi,

Copy the below code in the source workbook. Assuming all workbooks (source and target) are in same folder.

Sub copyData()
    Dim filePath As String
    Dim sheetnum As Integer, fileExist As String
    Dim targetWB As Workbook
    filePath = ThisWorkbook.Path
    
    Application.ScreenUpdating = False
    
    For sheetnum = 1 To ThisWorkbook.Sheets.Count
        fileExist = Dir(filePath & "\" & ThisWorkbook.Sheets(sheetnum).Name & ".xlsx")
        If fileExist <> vbNullString Then
            Set targetWB = Workbooks.Open(filePath & "\" & ThisWorkbook.Sheets(sheetnum).Name & ".xlsx")
            targetWB.Activate
            ThisWorkbook.Sheets(sheetnum).Copy Before:=targetWB.Sheets(Worksheets.Count)
            targetWB.Save
            targetWB.Close
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[TheHack22]

Hi,

Copy the below code in the source workbook. Assuming all workbooks (source and target) are in same folder.

Sub copyData()
    Dim filePath As String
    Dim sheetnum As Integer, fileExist As String
    Dim targetWB As Workbook
    filePath = ThisWorkbook.Path
   
    Application.ScreenUpdating = False
   
    For sheetnum = 1 To ThisWorkbook.Sheets.Count
        fileExist = Dir(filePath & "\" & ThisWorkbook.Sheets(sheetnum).Name & ".xlsx")
        If fileExist <> vbNullString Then
            Set targetWB = Workbooks.Open(filePath & "\" & ThisWorkbook.Sheets(sheetnum).Name & ".xlsx")
            targetWB.Activate
            ThisWorkbook.Sheets(sheetnum).Copy Before:=targetWB.Sheets(Worksheets.Count)
            targetWB.Save
            targetWB.Close
        End If
    Next
   
    Application.ScreenUpdating = True
End Sub

Saurabhj. Thanks very much. This works perfect. Just a follow up question.
I wanted to use this for a similar project, however the Excel workbooks always has the sheet tabs names(original) with something added-on, eg I might have "Canada_02.04.21" (Date as add on) or I might have "Western_Denesh"(Name as add on). But the name convention is always regions names first, then that "extra"
Is it possible to tweak a line from the Sub you provided to say something like:
Match Sheet tab names (These would always have the exact region name like, Western, Eastern, Canada etc) with files in a folder, but matching before the underscore( _ ). Can this be done by some wildcard syntax or some other way?
Imran

 

[Saurabhj]

Hi, Thanks for the feedback.

One query: In the sheet name, region name is always followed by underscore ( _ ) means Canada_

Thanks,
Saurabh

 

[TheHack22]

Hi, Thanks for the feedback.

One query: In the sheet name, region name is always followed by underscore ( _ ) means Canada_

Thanks,
Saurabh

HI Saurabh,

Thanks for your question and help.

The sheet name with the current data is always the standard name (Source Data) , eg Canada, Western, Southen. However, the main files (Destination) in a folder, names always start with like, "Canada_Denesh"or "Western_02.04.2021" or "Canada Revised". I will try to, moving forward be consistent with naming conventions as this: Name_Date ("Canada_02.04.2021").
So can the VBA Sub now compare FIle name "Canada_02.04.2021" with the Sheet Tab Name "Canada"? If this condition is true, copy and paste the data to update the destination files.

Thanks in advance for you help
Imran

 

[Saurabhj]

Hi, Thanks for details and screenshot.

Please use below code:

Sub copyData()
    Dim filePath As String
    Dim sheetnum As Integer, fileExist As String
   Dim fileName As String
    
    Dim targetWB As Workbook
    filePath = ThisWorkbook.Path
    Application.ScreenUpdating = False
    
    For sheetnum = 1 To ThisWorkbook.Sheets.Count
                        
        fileName = Dir(filePath & "\" & ThisWorkbook.Sheets(sheetnum).Name & "*.xlsx")

        If fileName <> vbNullString Then
            Set targetWB = Workbooks.Open(filePath & "\" & fileName)
            targetWB.Activate
            ThisWorkbook.Sheets(sheetnum).Copy Before:=targetWB.Sheets(Worksheets.Count)
            targetWB.Save
            targetWB.Close
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[TheHack22]

HI Saurabh,

You're the best. Your codes are so fast and efficient. Thanks a million. This works perfectly.

Best,
Imran

 

[Saurabhj]

Thanks a lot Imran for the feedback.