Importing specific cell data from one workbook to another

[Lelewiwi]

Good morning,

I've been working on this for days and am getting a little frustrated. I am trying to import specific cell data from Workbook1 to Workbook2. This needs to be an on-demand action so a button would be best to simplify matters. The button should be on Workbook2 as Workbook1 will change every time. I have never written code nor even looked at anything resembling code so please bear with me and give me simple instructions.

I would like the button to do the following actions:
*Open a window to select Workbook1
*Once Workbook1 is selected, import multiple specific cell data to Workbook2

Data will be a mixture of text, numbers and formulas.

Below is what I have so far. The choose file part works great, however, I get a "Subscript out of range" error when it tries to import the data.

Thanks for the help!

Public Sub subImportData()
Dim fd As Office.FileDialog
Dim strFile As String
Dim WbThisWorkbook As Workbook
Dim WbImportFrom As Workbook

ActiveWorkbook.Save

Application.ScreenUpdating = False

Set WbThisWorkbook = ThisWorkbook

Set fd = Application.FileDialog(msoFileDialogFilePicker)

With fd

.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx?", 1
.Filters.Add "Excel Files", "*.xlsm?", 1
.Title = "Choose an Excel file"
.AllowMultiSelect = False

.InitialFileName = ActiveWorkbook.Path

If .Show = True Then

strFile = .SelectedItems(1)

End If

End With

If strFile = "" Then
Application.ScreenUpdating = True
Exit Sub
End If

Workbooks.Open strFile, ReadOnly:=True
Set WbImportFrom = ActiveWorkbook

WbThisWorkbook.Sheets("Sheet1").Range("H7").Value = WbImportFrom.Sheets("Sheet1").Range("B1").Value
WbThisWorkbook.Sheets("Sheet1").Range("R5").Value = WbImportFrom.Sheets("Sheet1").Range("B2").Value
WbThisWorkbook.Sheets("Sheet1").Range("E25").Value = WbImportFrom.Sheets("Sheet2").Range("C27").Value
WbThisWorkbook.Sheets("Sheet1").Range("E26").Value = WbImportFrom.Sheets("Sheet2").Range("C28").Value
WbThisWorkbook.Sheets("Sheet1").Range("E27").Value = WbImportFrom.Sheets("Sheet2").Range("C29").Value
WbThisWorkbook.Sheets("Sheet1").Range("D32").Value = WbImportFrom.Sheets("Sheet1").Range("B7").Value

WbImportFrom.Close

Application.ScreenUpdating = True

ActiveWorkbook.Save

End Sub

 

[rlv01]

Below is what I have so far. The choose file part works great, however, I get a "Subscript out of range" error when it tries to import the data.

In general that error means that some element or object that you are counting on is missing. With your code it could mean that the workbook you open does not have a "Sheet1" for example.

This version has some code to check for that.

Public Sub subImportData()
    Dim fd As Office.FileDialog
    Dim strFile As String
    Dim WbThisWorkbook As Workbook
    Dim WbImportFrom As Workbook
    Dim srcWS As Worksheet, destWS As Worksheet
    Dim Found As Boolean
    
    ActiveWorkbook.Save
    
    Application.ScreenUpdating = False
    
    Set WbThisWorkbook = ThisWorkbook
    
    On Error Resume Next
    Set destWS = WbThisWorkbook.Worksheets("Sheet1")
    On Error GoTo 0
    
    If destWS Is Nothing Then
        MsgBox """Sheet1"" not found in " & WbThisWorkbook.Name, vbOKOnly Or vbCritical, "Error"
        Exit Sub
    End If
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsx?", 1
        .Filters.Add "Excel Files", "*.xlsm?", 1
        .Title = "Choose an Excel file"
        .AllowMultiSelect = False
        
        .InitialFileName = ActiveWorkbook.Path
        
        If .Show = True Then
            
            strFile = .SelectedItems(1)
            
        End If
        
    End With
    
    If strFile = "" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If

    Set WbImportFrom = Workbooks.Open(strFile, ReadOnly:=True)
    
    For Each srcWS In WbImportFrom.Worksheets
        With destWS
            Select Case srcWS.Name
                Case "Sheet1"
                    Found = True
                    .Range("H7").Value = srcWS.Range("B1").Value
                    .Range("R5").Value = srcWS.Range("B2").Value
                    .Range("D32").Value = srcWS.Range("B7").Value
                Case "Sheet2"
                    Found = True
                    .Range("E25").Value = srcWS.Range("C27").Value
                    .Range("E26").Value = srcWS.Range("C28").Value
                    .Range("E27").Value = srcWS.Range("C29").Value
            End Select
        End With
    Next srcWS
    
    If Not Found Then
        MsgBox "Source worksheets not found in:" & vbCr & WbImportFrom.Name, vbOKOnly Or vbCritical, "Error"
    End If
    
    WbImportFrom.Close False
    Application.ScreenUpdating = True
    ActiveWorkbook.Save
End Sub