Copy data from workbook where filename and tab name match

[TaskMaster]

Hi all,

Hoping that someone can help me with the following. I have a spreadsheet called Weekly Report with tabs named days of the week and spreadsheets containing data sharing the same name. E.g copying data from a workbook called Monday into the tab called Monday in my weekly report file. I want do something similar for product codes however to do this for each code would take some time. Is there a way that I could automate it so that if the tabs in my weekly report spreadsheet share the same as the file in a selected folder it would copy the data from that spreadsheet into the tabs listed. Thank you in advance.

Sub Data()

Dim Folder As String
Dim Monday As String
Dim Tuesday As String
Dim Wednesday As String
Dim Thursday As String
Dim Friday As String

Folder =  "C:\Users\Flow\Desktop\Test\"

'Monday
Workbooks.Open Filename:=Folder & "Monday.xlsx"
    Range("A2:BF2000").Copy
    Windows("Weekly Report.xlsm").Activate
    Sheets("Monday").Range("A2").PasteSpecial Paste:=xlPasteValues
    
'Tuesday
Workbooks.Open Filename:=Folder & "Tuesday.xlsx"
    Range("A2:BF2000").Copy
    Windows("Weekly Report.xlsm").Activate
    Sheets("Tuesday").Range("A2").PasteSpecial Paste:=xlPasteValues
    
'Wednesday
Workbooks.Open Filename:=Folder & "Wednesday.xlsx"
    Range("A2:BF2000").Copy
    Windows("Weekly Report.xlsm").Activate
    Sheets("Wednesday").Range("A2").PasteSpecial Paste:=xlPasteValues
    
'Thursday
Workbooks.Open Filename:=Folder & "Thursday.xlsx"
    Range("A2:BF2000").Copy
    Windows("Weekly Report.xlsm").Activate
    Sheets("Thursday").Range("A2").PasteSpecial Paste:=xlPasteValues

'Friday
Workbooks.Open Filename:=Folder & "Friday.xlsx"
    Range("A2:BF2000").Copy
    Windows("Weekly Report.xlsm").Activate
    Sheets("Friday").Range("A2").PasteSpecial Paste:=xlPasteValues
    
    End Sub

 

[rlv01]

Why not do it in exactly the same way you have done it for weekdays?

(Not tested)

Sub ProductCodeData()
    Dim Folder As String, FilePath As String
    Dim WBMain As Workbook, WBProductCode As Workbook
    Dim WS As Worksheet
    Dim ProductCodes() As Variant
    Dim ProductCode As Variant

    ProductCodes = Array("Code1", "Code2", "Code3", "Code4", "Code5")

    Folder = "C:\Users\Flow\Desktop\Test\"
    'Set WBMain = ThisWorkbook
    Set WBMain = Application.Workbooks("Weekly Report.xlsm")

    With CreateObject("Scripting.FileSystemObject")
        For Each ProductCode In ProductCodes
            FilePath = Folder & ProductCode & ".xlsx"
            On Error Resume Next
            Set WS = WBMain.Worksheets(ProductCode)
            On Error GoTo 0
            If .FileExists(FilePath) And Not (WS Is Nothing) Then
                Set WBProductCode = Application.Workbooks.Open(FileName:=FilePath)
                WBProductCode.Worksheets(1).Range("A2:BF2000").Copy    'or whatever
                WS.Range("A2").PasteSpecial Paste:=xlPasteValues
                WBProductCode.Close False
                DoEvents
            End If
            WS = Nothing
        Next ProductCode
    End With
    WBMain.Activate
End Sub

 

[TaskMaster]

WS = Nothing

Hi, thank you for your reply, sorry for the delay in getting back to you as I have been away for a few days.

This works for the first product code however seems to be falling over at this stage (for all the subsequent codes).

The reason I wanted something a little more dynamic is that the product codes can change from week to week and therefore was hoping for something which needn't be updated when there is new product codes, i.e would pick up the file name from the tab name if this is at all possible.

 

[rlv01]

Should be

Set WS = nothing

Better just to report the actual error message (i.e. "Run-time error '91': Object variable or With block variable not set") rather than a vague term like "falling over", since the latter gives me nowhere to go as far as analyzing what went wrong.

 

[rlv01]

Sub ProductCodeData()
    Dim Folder As String, FilePath As String
    Dim WBMain As Workbook, WBProductCode As Workbook
    Dim ProductCodeWS As Worksheet
    Dim ProductCodes() As Variant
    Dim ProductCode As Variant
    Dim FileError As Boolean
    Dim MissingFiles As String
    
    Folder = "C:\Users\Flow\Desktop\Test\"
    Set WBMain = ThisWorkbook
    'Set WBMain = Application.Workbooks("Weekly Report.xlsm")
    
    With CreateObject("Scripting.FileSystemObject")
        For Each ProductCodeWS In WBMain.Worksheets
            ProductCode = ProductCodeWS.Name
            FilePath = Folder & ProductCode & ".xlsx"
            FileError = Not .FileExists(FilePath)
            Select Case ProductCodeWS.Name
                Case "Main", "Index", "Summary" 'ignore list
                Case Else
                    If FileError Then
                        MissingFiles = MissingFiles & FilePath & vbCr
                    End If
                    
                    If Not FileError Then
                        Application.StatusBar = "Processing product code: " & ProductCode
                        Set WBProductCode = Application.Workbooks.Open(Filename:=FilePath)
                        WBProductCode.Worksheets(1).Range("A2:BF2000").Copy    'or whatever
                        ProductCodeWS.Range("A2").PasteSpecial Paste:=xlPasteValues
                        WBProductCode.Close False
                        DoEvents
                    End If
            End Select
        Next ProductCodeWS
    End With
    WBMain.Activate
    
    If MissingFiles <> "" Then
        MissingFiles = "Missing product code workbook files:" & vbCr & vbCr & MissingFiles
        MsgBox MissingFiles, vbExclamation
    End If
End Sub

 

[TaskMaster]

Hi, I have just tested this and it works perfectly.

This is going to save me hours of manual intervention every week!