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

[Jasen]

Hi!

I need a macro to copy a range of cells from a range of sheets from a closed workbook chosen by file browser and I'm not sure where to start.

C8:AG16, C19:AG21, C29:AG26, C29:AG32 from sheets 5:34 to the same locations in the current workbook.

Also from Sheets5:34 cell Q2 from the target workbook copied to the same sheet in the current workbook but to cell O2 instead.

My knowledge here is limited so any help would be appreciated! Thanks

[Domenic]

The following code uses ExecuteExcel4Macro to retrieve the values from a closed workbook. With more than 30 sheets, though, you may find it somewhat slow. In any case, try adopting the following code and see how well it works for you. Note that it is assumed that the "current workbook" is the active workbook. Also, you should turn off screen updating, and include the appropriate error handling.

Option Explicit

Sub test()

    Dim sFullName As String
    Dim sPath As String
    Dim sFile As String
    Dim vRanges As Variant
    Dim rRange As Range
    Dim ShtIndx As Integer
    Dim RngIndx As Integer
    Dim r As Long
    Dim c As Long
    
    sFullName = "c:\users\domenic\desktop\sample.xlsm"
    
    sPath = Left(sFullName, InStrRev(sFullName, "\"))
    
    sFile = Mid(sFullName, InStrRev(sFullName, "\") + 1)
    
    vRanges = Array("C8:AG16", "C19:AG21", "C29:AG26", "C29:AG32")
    
    For ShtIndx = 5 To 34
        With Worksheets(ShtIndx)
            For RngIndx = 0 To UBound(vRanges)
                Set rRange = .Range(vRanges(RngIndx))
                For r = 1 To rRange.Rows.Count
                    For c = 1 To rRange.Columns.Count
                        rRange(r, c).Value = GetValue(sPath, sFile, .Name, rRange(r, c).Address(, , xlR1C1))
                        .Range("O2").Value = GetValue(sPath, sFile, .Name, .Range("Q2").Address(, , xlR1C1))
                    Next c
                Next r
            Next RngIndx
        End With
    Next ShtIndx
    
End Sub

Private Function GetValue(sPath, sFile, sSheet, sRef)
    Dim sArg As String
    If Right(sPath, 1) <> "\" Then
        sPath = sPath & "\"
    End If
    sArg = "'" & sPath & "[" & sFile & "]" & sSheet & "'!" & sRef
    GetValue = ExecuteExcel4Macro(sArg)
End Function

Hope this helps!

[Jasen]

Thanks for the reply.

It is prompting me to select file for each cell that is copied. I had to force close excel otherwise I'd have a whole load of cancel buttons to hit haha.

The following code uses ExecuteExcel4Macro to retrieve the values from a closed workbook. With more than 30 sheets, though, you may find it somewhat slow. In any case, try adopting the following code and see how well it works for you. Note that it is assumed that the "current workbook" is the active workbook. Also, you should turn off screen updating, and include the appropriate error handling.

Option Explicit

Sub test()

    Dim sFullName As String
    Dim sPath As String
    Dim sFile As String
    Dim vRanges As Variant
    Dim rRange As Range
    Dim ShtIndx As Integer
    Dim RngIndx As Integer
    Dim r As Long
    Dim c As Long
    
    sFullName = "c:\users\domenic\desktop\sample.xlsm"
    
    sPath = Left(sFullName, InStrRev(sFullName, "\"))
    
    sFile = Mid(sFullName, InStrRev(sFullName, "\") + 1)
    
    vRanges = Array("C8:AG16", "C19:AG21", "C29:AG26", "C29:AG32")
    
    For ShtIndx = 5 To 34
        With Worksheets(ShtIndx)
            For RngIndx = 0 To UBound(vRanges)
                Set rRange = .Range(vRanges(RngIndx))
                For r = 1 To rRange.Rows.Count
                    For c = 1 To rRange.Columns.Count
                        rRange(r, c).Value = GetValue(sPath, sFile, .Name, rRange(r, c).Address(, , xlR1C1))
                        .Range("O2").Value = GetValue(sPath, sFile, .Name, .Range("Q2").Address(, , xlR1C1))
                    Next c
                Next r
            Next RngIndx
        End With
    Next ShtIndx
    
End Sub

Private Function GetValue(sPath, sFile, sSheet, sRef)
    Dim sArg As String
    If Right(sPath, 1) <> "\" Then
        sPath = sPath & "\"
    End If
    sArg = "'" & sPath & "[" & sFile & "]" & sSheet & "'!" & sRef
    GetValue = ExecuteExcel4Macro(sArg)
End Function

Hope this helps!

[Domenic]

That's because it can't find the specified file. You'll need to assign the string variable sFullName the appropriate filename. You mentioned that you're using a file browser to select the file. So assign the selected file to the variable sFullName.

[Jasen]

Oh sorry, I meant I need the macro to let me/the user choose the file as I need to send out an updated version of a workbook to multiple people and they will have different filenames/locations for the target. I should have given more detail.

[Domenic]

In that case, try...

    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

Hope this helps!

[Jasen]

So close!

That sorts out the file selection and it goes and pastes everything in the right place etc. Only issue seems to be that if the sheets don't share the same name on the source as the target then all I get is #REF! on the target workbook. They are all the same sheet number but the sheetnames will vary from user to user. If this is causing the issue then the sheetnames are on a sheet called "Targets" on the source workbook cells B4:B33.

Thanks so much for your help so far, I wouldn't have had a clue where to start. Any websites or books you can recommend I look into to pick this up?

In that case, try...

    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

Hope this helps!

[Domenic]

Sorry, but I'm a bit confused. How are we going to refer to the worksheets for both the source and destination workbooks? Are we going to refer to them by sheet name (ie. Sheet5, Sheet6, Sheet7 ... Sheet54)? By their index number (ie. 5, 6, 7 ... 54)? Or something else? Can you please elaborate?

[Jasen]

Apologies. I am confusing myself and am mostly self taught so don't know a lot of the correct terminology.

The sheetnames will not be the same on the source and destination as the source will have had data input into it that has dynamically updated the names of the sheets. So I assume index number is what I mean - in the VBA project explorer they are listed as Sheet# (Name) and I'm referring to the Sheet# due to the sheet name being different for the different end users that this will be needed by. Does that make sense? I'm a noob with VBA so I don't know what I'm restricted by to make this work. Thanks for your patience

Sorry, but I'm a bit confused. How are we going to refer to the worksheets for both the source and destination workbooks? Are we going to refer to them by sheet name (ie. Sheet5, Sheet6, Sheet7 ... Sheet54)? By their index number (ie. 5, 6, 7 ... 54)? Or something else? Can you please elaborate?

[Domenic]

Actually, in my code, I do refer to the worksheets by index number. But maybe I should have used the Sheets collection, instead of the Worksheets collection. Try replacing...

With Worksheets(ShtIndx)

with

With Sheets(ShtIndx)

Does this help?

[Jasen]

So, like this?

Option Explicit

Sub test()

Dim sFullName As String
Dim sPath As String
Dim sFile As String
Dim vRanges As Variant
Dim rRange As Range
Dim ShtIndx As Integer
Dim RngIndx As Integer
Dim r As Long
Dim c As Long

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

sPath = Left(sFullName, InStrRev(sFullName, "\"))

sFile = Mid(sFullName, InStrRev(sFullName, "\") + 1)

vRanges = Array("C8:AG16", "C19:AG21", "C29:AG26", "C29:AG32")

For ShtIndx = 5 To 34
With Sheets(ShtIndx)
For RngIndx = 0 To UBound(vRanges)
Set rRange = .Range(vRanges(RngIndx))
For r = 1 To rRange.Rows.Count
For c = 1 To rRange.Columns.Count
rRange(r, c).Value = GetValue(sPath, sFile, .Name, rRange(r, c).Address(, , xlR1C1))
.Range("O2").Value = GetValue(sPath, sFile, .Name, .Range("Q2").Address(, , xlR1C1))
Next c
Next r
Next RngIndx
End With
Next ShtIndx

End Sub

Private Function GetValue(sPath, sFile, sSheet, sRef)
Dim sArg As String
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
sArg = "'" & sPath & "[" & sFile & "]" & sSheet & "'!" & sRef
GetValue = ExecuteExcel4Macro(sArg)
End Function

Actually, in my code, I do refer to the worksheets by index number. But maybe I should have used the Sheets collection, instead of the Worksheets collection. Try replacing...

With Worksheets(ShtIndx)

with

With Sheets(ShtIndx)

Does this help?

[Domenic]

Yes, that's right. Does it help? I suspect that it won't, in which case I'll provide you with an alternative approach.

[Jasen]

It sets about copy/pasting but returns #REF! for the sheets that have been renamed in the source still.

Yes, that's right. Does it help? I suspect that it won't, in which case I'll provide you with an alternative approach.

[Domenic]

Okay, so it looks like we won't be able to refer to the sheets by index number. So if I understand you correctly, the code name (not the sheet name) will be the same for both the source and destination workbooks, correct? While the sheet names will differ, correct?

Once you confirm the above, I'll provide you with an alternative. However, it looks like I won't get a chance until sometime later this evening.

[Jasen]

No rush I really appreciate it. What do you mean by code name?

Okay, so it looks like we won't be able to refer to the sheets by index number. So if I understand you correctly, the code name (not the sheet name) will be the same for both the source and destination workbooks, correct? While the sheet names will differ, correct?

Once you confirm the above, I'll provide you with an alternative. However, it looks like I won't get a chance until sometime later this evening.

[Domenic]

Earlier you mentioned...

Sheet# (Name)

The code name is Sheet#. So will the code name be the same for both the source and destination workbooks?

[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!