Copy data from a range of cells and sheets in a closed workbook

[Jasen]

Yep the work books will be basically the same, the sheet names will just vary for Sheet5 to Sheet34 for the the different sources. They are named "1" through to "30" in the destination and the multiple end-users' sources' sheet names will vary depending on the names of people in a sales team. They're all Sheet5 (Person1), Sheet6 (Person2), Sheet7 (Person3) and so on, essentially.

[Domenic]

In the following code, add other code names for your sheets, where indicated. Also, you'll need to allow access to the VBProject object model...

Ribbon > Developer > Macro Security > Macro Settings > select/check Trust access to the VBA project object model

Option Explicit

Sub RetrieveValues()

    Dim sFullName As String
    Dim wkbSource As Workbook
    Dim wksSource As Worksheet
    Dim wkbDest As Workbook
    Dim wksDest As Worksheet
    Dim vCodeNames As Variant
    Dim vCodeName As Variant
    Dim vRanges As Variant
    Dim RngIndx As Integer
    
    sFullName = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xlsx;*.xlsm;*.xlsb;*.xls), *.xlsx;*.xlsm;*.xlsb;*.xls", _
        Title:="Select a File", _
        ButtonText:="Select")
 
    If sFullName = "False" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    On Error GoTo ErrHandler
    
    Set wkbDest = ActiveWorkbook
    
    Set wkbSource = Workbooks.Open(Filename:=sFullName, ReadOnly:=True)
    
    vCodeNames = Array("Sheet5", "Sheet6", "Sheet7") 'add other code names accordingly
    
    vRanges = Array("C8:AG16", "C19:AG21", "C29:AG26", "C29:AG32")
    
    For Each vCodeName In vCodeNames
        Set wksSource = wkbSource.Worksheets(CStr(wkbSource.VBProject.VBComponents(vCodeName).Properties("Name")))
        Set wksDest = wkbDest.Worksheets(CStr(wkbDest.VBProject.VBComponents(vCodeName).Properties("Name")))
        For RngIndx = 0 To UBound(vRanges)
            wksDest.Range(vRanges(RngIndx)).Value = wksSource.Range(vRanges(RngIndx)).Value
        Next RngIndx
        wksDest.Range("O2").Value = wksSource.Range("Q2").Value
    Next vCodeName
    
    wkbSource.Close savechanges:=False
    
ExitSub:
    Application.ScreenUpdating = True
    Set wkbSource = Nothing
    Set wkbDest = Nothing
    Set wksDest = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "Error " & Err.Number & ":" & Chr(10) & Chr(10) & Err.Description
    Resume ExitSub
    
End Sub

Hope this helps!

[Jasen]

Total superstar it works a charm! Many many thanks.
Can I be a total pain in the rear end and ask if it's possible to add in:
The copying of Sheet1 in its entirety,
Cells C2 and A4:C33 of Sheet 2
Cell Q2 of Sheet4 copied to Cell O2 of destination Sheet4?

Then I'll leave you alone I promise

In the following code, add other code names for your sheets, where indicated. Also, you'll need to allow access to the VBProject object model...

Ribbon > Developer > Macro Security > Macro Settings > select/check Trust access to the VBA project object model

Option Explicit

Sub RetrieveValues()

    Dim sFullName As String
    Dim wkbSource As Workbook
    Dim wksSource As Worksheet
    Dim wkbDest As Workbook
    Dim wksDest As Worksheet
    Dim vCodeNames As Variant
    Dim vCodeName As Variant
    Dim vRanges As Variant
    Dim RngIndx As Integer
    
    sFullName = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xlsx;*.xlsm;*.xlsb;*.xls), *.xlsx;*.xlsm;*.xlsb;*.xls", _
        Title:="Select a File", _
        ButtonText:="Select")
 
    If sFullName = "False" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    On Error GoTo ErrHandler
    
    Set wkbDest = ActiveWorkbook
    
    Set wkbSource = Workbooks.Open(Filename:=sFullName, ReadOnly:=True)
    
    vCodeNames = Array("Sheet5", "Sheet6", "Sheet7") 'add other code names accordingly
    
    vRanges = Array("C8:AG16", "C19:AG21", "C29:AG26", "C29:AG32")
    
    For Each vCodeName In vCodeNames
        Set wksSource = wkbSource.Worksheets(CStr(wkbSource.VBProject.VBComponents(vCodeName).Properties("Name")))
        Set wksDest = wkbDest.Worksheets(CStr(wkbDest.VBProject.VBComponents(vCodeName).Properties("Name")))
        For RngIndx = 0 To UBound(vRanges)
            wksDest.Range(vRanges(RngIndx)).Value = wksSource.Range(vRanges(RngIndx)).Value
        Next RngIndx
        wksDest.Range("O2").Value = wksSource.Range("Q2").Value
    Next vCodeName
    
    wkbSource.Close savechanges:=False
    
ExitSub:
    Application.ScreenUpdating = True
    Set wkbSource = Nothing
    Set wkbDest = Nothing
    Set wksDest = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "Error " & Err.Number & ":" & Chr(10) & Chr(10) & Err.Description
    Resume ExitSub
    
End Sub

Hope this helps!

[Domenic]

Try...

Option Explicit

Sub RetrieveValues()

    Dim sFullName As String
    Dim wkbSource As Workbook
    Dim wksSource As Worksheet
    Dim wkbDest As Workbook
    Dim wksDest As Worksheet
    Dim vCodeNames As Variant
    Dim vCodeName As Variant
    Dim vRanges As Variant
    Dim RngIndx As Integer
    
    sFullName = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xlsx;*.xlsm;*.xlsb;*.xls), *.xlsx;*.xlsm;*.xlsb;*.xls", _
        Title:="Select a File", _
        ButtonText:="Select")
 
    If sFullName = "False" Then Exit Sub
    
    Application.ScreenUpdating = False
    
    On Error GoTo ErrHandler
    
    Set wkbDest = ActiveWorkbook
    
    Set wkbSource = Workbooks.Open(Filename:=sFullName, ReadOnly:=True)

'   Retrieve values from sheet with the code name Sheet1
    Set wksSource = wkbSource.Worksheets(CStr(wkbSource.VBProject.VBComponents("Sheet1").Properties("Name")))
    Set wksDest = wkbDest.Worksheets(CStr(wkbDest.VBProject.VBComponents("Sheet1").Properties("Name")))
    With wksSource.UsedRange
        wksDest.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With
    
'   Retrieve values from sheet with the code name Sheet2
    Set wksSource = wkbSource.Worksheets(CStr(wkbSource.VBProject.VBComponents("Sheet2").Properties("Name")))
    Set wksDest = wkbDest.Worksheets(CStr(wkbDest.VBProject.VBComponents("Sheet2").Properties("Name")))
    wksDest.Range("C2").Value = wksSource.Range("C2").Value
    wksDest.Range("A4:C33").Value = wksSource.Range("A4:C33").Value
    
'   Retrieve value from sheet with the code name Sheet4
    Set wksSource = wkbSource.Worksheets(CStr(wkbSource.VBProject.VBComponents("Sheet4").Properties("Name")))
    Set wksDest = wkbDest.Worksheets(CStr(wkbDest.VBProject.VBComponents("Sheet4").Properties("Name")))
    wksDest.Range("O2").Value = wksSource.Range("Q2").Value
    
'   Retrieve values from sheets with code names Sheet5 to Sheet34
    vCodeNames = Array("Sheet5", "Sheet6") 'add other code names accordingly
    vRanges = Array("C8:AG16", "C19:AG21", "C29:AG26", "C29:AG32")
    For Each vCodeName In vCodeNames
        Set wksSource = wkbSource.Worksheets(CStr(wkbSource.VBProject.VBComponents(vCodeName).Properties("Name")))
        Set wksDest = wkbDest.Worksheets(CStr(wkbDest.VBProject.VBComponents(vCodeName).Properties("Name")))
        For RngIndx = 0 To UBound(vRanges)
            wksDest.Range(vRanges(RngIndx)).Value = wksSource.Range(vRanges(RngIndx)).Value
        Next RngIndx
        wksDest.Range("O2").Value = wksSource.Range("Q2").Value
    Next vCodeName
    
    wkbSource.Close savechanges:=False
    
ExitSub:
    Application.ScreenUpdating = True
    Set wkbSource = Nothing
    Set wkbDest = Nothing
    Set wksDest = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "Error " & Err.Number & ":" & Chr(10) & Chr(10) & Err.Description
    Resume ExitSub
    
End Sub

Hope this helps!

[Jasen]

Does the trick! Thanks a million!