Switching to different workbooks & sheets

[bsturds]

I have a macro that pulls data from another book and needs to pull of many different spreadsheets in that book. When I run the macro to pull data from the first sheet referenced in the other book it works fine, but when the macro moves onto pulling from the second, 3rd, 4th sheets, it always prompts me to re-open the file. If I do this, it still pulls from the correct file, however I want the macro to seamlessly pull from each spreadsheet without prompting me to re-open the whole when it goes to do that. This is my code currently:

Sub Truck1Open()
Dim v, aug1 As Worksheet

Set v = ThisWorkbook.Sheets("Summary")

Dim filepath, f As String
Dim aug As Variant
Dim sn As String
Dim r As Range, myRange As Range
Dim xrow As Long
filepath = v.Cells(2, "K").Value


For Count = 2 To v.UsedRange.Rows.Count
aug = v.Cells(3, "K").Value
sn = v.Cells(Count, "G").Value


Workbooks.Open (filepath & "\" & aug & ".xlsx")
ActiveWorkbook.Worksheets(sn).Activate

With ActiveSheet
Range("B4").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 1).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 1), v.Cells(xrow, 1)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("B8").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 2).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 2), v.Cells(xrow, 2)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("B10").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 3).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 3), v.Cells(xrow, 3)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("D14").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 4).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 4), v.Cells(xrow, 4)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("D18").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 5).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 5), v.Cells(xrow, 5)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With

Next

End Sub



Thanks in advanve for any help.

[mehmetcik]

Your open workbook command is inside your loop. hence your issue.

Sub Truck1Open()
Dim v, aug1 As Worksheet

Set v = ThisWorkbook.Sheets("Summary")

Dim filepath, f As String
Dim aug As Variant
Dim sn As String
Dim r As Range, myRange As Range
Dim xrow As Long
filepath = v.Cells(2, "K").Value

**********************************************
'This is Outside your loop.
Workbooks.Open (filepath & "\" & aug & ".xlsx")
**********************************************

For Count = 2 To v.UsedRange.Rows.Count
aug = v.Cells(3, "K").Value
sn = v.Cells(Count, "G").Value

**********************************************
'This is inside your loop.  So I disabled it.
'Workbooks.Open (filepath & "\" & aug & ".xlsx")
**********************************************

ActiveWorkbook.Worksheets(sn).Activate

With ActiveSheet
Range("B4").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 1).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 1), v.Cells(xrow, 1)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("B8").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 2).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 2), v.Cells(xrow, 2)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("B10").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 3).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 3), v.Cells(xrow, 3)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("D14").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 4).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 4), v.Cells(xrow, 4)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With


Workbooks(aug & ".xlsx").Activate
Workbooks(aug & ".xlsx").Worksheets(sn).Select
With ActiveSheet
Range("D18").Select
Selection.Copy
End With
v.Activate
With ActiveSheet
xrow = v.Cells(v.Rows.Count, 5).End(xlUp).Row + 1
v.Range(v.Cells(xrow, 5), v.Cells(xrow, 5)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With

Next

End Sub

[bsturds]

Thanks for the reply mehmetcik, but when I get to ActiveWorkbook.Worksheets(sn).Activate (after your correction) I get run time error 9. For some reason I dont think it is recognizing the ActiveWorkbook as the one it just opened.

[Olly]

There's a lot of repetition and redundancy in your code. Hard to test without seeing your workbook, but try something like:

Sub foo()
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet, wsTgt As Worksheet
    Dim lRow As Long
    
    Set wsTgt = ThisWorkbook.Worksheets("Summary")
    With wsTgt
        wbSrc = Workbooks.Open(.Range("K2").Value & "\" & .Range("K3").Value & ".xlsx")
        For lRow = 2 To .UsedRange.Rows.Count
            Set wsSrc = wbSrc.Worksheets(.Cells(lRow, "G"))
            With .Cells(.Rows.Count, 1).End(xlUp)
                .Offset(1, 0).Value = wsSrc.Range("B4").Value
                .Offset(1, 1).Value = wsSrc.Range("B8").Value
                .Offset(1, 2).Value = wsSrc.Range("B10").Value
                .Offset(1, 3).Value = wsSrc.Range("D14").Value
                .Offset(1, 4).Value = wsSrc.Range("D18").Value
            End With
        Next l
    End With
End Sub

So it opens the source workbook, based on values in K2 and K3. Then loops through each value from G2:G(lastrow), and copies values (as specified; B4, B8, B10, D14, D18) to A:E of next blank row, from the worksheet as specified in column G. Is that about right?!

[bsturds]

Thats for the reply Olly,When it gets to this line *wbSrc = Workbooks.Open(.Range("K2").Value & "\" & .Range("K3").Value & ".xlsx")* I get run time error 91 - Object variable or With block variable not set. I appologize for the redundancy I am extremely new to vba.

[Olly]

Thats for the reply Olly,When it gets to this line *wbSrc = Workbooks.Open(.Range("K2").Value & "\" & .Range("K3").Value & ".xlsx")* I get run time error 91 - Object variable or With block variable not set. I appologize for the redundancy I am extremely new to vba.

Sorry, I did a quick edit - try the corrected code posted now.

To avoid confusion:

Sub foo()
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet, wsTgt As Worksheet
    Dim lRow As Long
    
    Set wsTgt = ThisWorkbook.Worksheets("Summary")
    With wsTgt
        wbSrc = Workbooks.Open(.Range("K2").Value & "\" & .Range("K3").Value & ".xlsx")
        For lRow = 2 To .UsedRange.Rows.Count
            Set wsSrc = wbSrc.Worksheets(.Cells(lRow, "G"))
            With .Cells(.Rows.Count, 1).End(xlUp)
                .Offset(1, 0).Value = wsSrc.Range("B4").Value
                .Offset(1, 1).Value = wsSrc.Range("B8").Value
                .Offset(1, 2).Value = wsSrc.Range("B10").Value
                .Offset(1, 3).Value = wsSrc.Range("D14").Value
                .Offset(1, 4).Value = wsSrc.Range("D18").Value
            End With
        Next l
    End With
End Sub

[mehmetcik]

In which case

Insert a line to activate your original workbook.

workbook("Your Workbook Name").activate

[bsturds]

Thanks Olly, I just tried your new code, I think *wbSrc.Worksheets(.Cells(lRow, "G"))* is where the issue lies. The workbook will open, but when it comes to selecting the worksheets it is not recognizing.

[Olly]

Okay, now I really need to see your workbook.

Remember to desensitize the data.

Click on GO ADVANCED and use the paperclip icon to open the upload window.

View Pic

[bsturds]

I attatched desenesitized versions of the workbooks. Thanks a ton Olly.

[Olly]

Okay. Made some small tweaks to the code...

Sub foo()
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet, wsTgt As Worksheet
    Dim stFileName As String
    Dim lRow As Long
    
    Application.ScreenUpdating = False
    On Error GoTo ErrHandler
    
    Set wsTgt = Worksheets("Summary")
    With wsTgt
        stFileName = .Range("K2").Value & "\" & .Range("K3").Value & ".xlsx"
        Set wbSrc = Workbooks.Open(stFileName, False)
        For lRow = 2 To .Cells(Rows.Count, "G").End(xlUp).Row
            Set wsSrc = wbSrc.Worksheets(.Cells(lRow, "G").Value)
                With .Cells(.Rows.Count, 1).End(xlUp)
                    .Offset(1, 0).Value = wsSrc.Range("B4").Value
                    .Offset(1, 1).Value = wsSrc.Range("B8").Value
                    .Offset(1, 2).Value = wsSrc.Range("B10").Value
                    .Offset(1, 3).Value = wsSrc.Range("D14").Value
                    .Offset(1, 4).Value = wsSrc.Range("D18").Value
                End With
NextWS:
        Next lRow
        wbSrc.Close (False)
    End With
    
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    Debug.Print Err.Number & " - " & Err.Description, wbSrc.Name & "[" & wsTgt.Cells(lRow, "G").Value & "]"
    Resume NextWS
End Sub

Your example files will fail as you have mistyped "Dallas" in cell G3. The revised code handles this error, and tells you where the error happened, in the immediates window.

[bsturds]

Thanks for all the work Olly. Still not working though. Opens the spreadsheet, but doesnt pull any values!

[Olly]

Did you change the name of "Sheet1" to "Summary"? That's all I can think of which is preventing it working. Works on your sample files. See my attachment (oh, and obviously, change values in K2 and K3)

[bsturds]

This is rediculous I have no idea why this wont work. I appreciate all of your help though olly!

[Olly]

Did you try my attachment? Did it still fail completely?

After the macro had run, what error messages were in the Immediates window of the VBE (Ctrl-G to show immediates window) ?

[bsturds]

Just got it working. My reference cell had a space at the end. Olly, thank you so much!!!

[Olly]

Just got it working. My reference cell had a space at the end. Olly, thank you so much!!!

The devil's in the detail

Glad you got it working

[Olly]

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. You can also Add Reputation to posts you found helpful, by clicking the "* Add Reputation" button to the lower left of the post. Thanks.