Open workbooks update the main one and close the other workbooks

**stojko89** · 07-18-2013, 03:13 AM

Hi,

What I'm tryn to do here is ask how can I on 4 different sheet open workbooks that are hyperlinked in cells so it would open the workbook on sheet 1 update the table and close the workbook.
And then move down to the next hyperlinked cell and update the main workbook from the opened one and close it down.
Then move to the next sheet to the next hyperlinked cell and to do the same untill it updated all the tables on all 4 sheets for all hyperlinked cells.
I don't know how to realy ask this...

But I have a code that has named ranges.

Set PO103641 = Worksheets(1).Range("D11:D32")
Set PO103642 = Worksheets(1).Range("D34:D55")
Set PO103643 = Worksheets(1).Range("D57:D77")
Set PO103644 = Worksheets(1).Range("D79:D99")
Set PO103645 = Worksheets(1).Range("D101:D121")
Set PO103651 = Worksheets(2).Range("D11:D31")
Set PO103681 = Worksheets(3).Range("D11:D26")
Set PO103682 = Worksheets(3).Range("D28:D47")
Set PO103683 = Worksheets(3).Range("D49:D68")
Set PO103684 = Worksheets(3).Range("D70:D86")
Set PO103685 = Worksheets(3).Range("D88:D99")
Set PO103701 = Worksheets(4).Range("D11:D30")
Set PO103702 = Worksheets(4).Range("D32:D47")
Set PO103703 = Worksheets(4).Range("D49:D68")

The hyperlinked cell is one cell above the begining of the named range.
For example for sheet 3 Range D11:D26 the hyperlinked cell is D10
For sheet 4 Range D32:D47 the hyperlinked cell is D31.

The hyperlink cell is the address of where the file is on the computer/server.

My whole code is this:

Sub UpdateTable()
'Update the table in Eureka-IMPRO worksheet with information from a chosen workbook
Dim x As Range, xf As Range, NR As Range
Dim PO103641 As Range, PO103642 As Range, PO103643 As Range, PO103644 As Range, PO103645 As Range
Dim PO103651 As Range
Dim PO103681 As Range, PO103682 As Range, PO103683 As Range, PO103684 As Range, PO103685 As Range
Dim PO103701 As Range, PO103702 As Range, PO103703 As Range
Dim sFilename As String, sPathname As String
Dim wbOp As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

sPathname = "U:\Skupno\Eureka Pumps AS\"
Set ws1 = ThisWorkbook.ActiveSheet
Set PO103641 = Worksheets(1).Range("D11:D32")
Set PO103642 = Worksheets(1).Range("D34:D55")
Set PO103643 = Worksheets(1).Range("D57:D77")
Set PO103644 = Worksheets(1).Range("D79:D99")
Set PO103645 = Worksheets(1).Range("D101:D121")
Set PO103651 = Worksheets(2).Range("D11:D31")
Set PO103681 = Worksheets(3).Range("D11:D26")
Set PO103682 = Worksheets(3).Range("D28:D47")
Set PO103683 = Worksheets(3).Range("D49:D68")
Set PO103684 = Worksheets(3).Range("D70:D86")
Set PO103685 = Worksheets(3).Range("D88:D99")
Set PO103701 = Worksheets(4).Range("D11:D30")
Set PO103702 = Worksheets(4).Range("D32:D47")
Set PO103703 = Worksheets(4).Range("D49:D68")

If ActiveSheet.Name = Worksheets(1).Name Then GoTo PO10364
If ActiveSheet.Name = Worksheets(2).Name Then GoTo PO10365
If ActiveSheet.Name = Worksheets(3).Name Then GoTo PO10368
If ActiveSheet.Name = Worksheets(4).Name Then GoTo PO10370

PO10364:
If Not Intersect(ActiveCell, PO103641) Is Nothing Then
    Set NR = PO103641
    ChDir sPathname & Range("A10").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103642) Is Nothing Then
    Set NR = PO103642
    ChDir sPathname & Range("A33").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103644) Is Nothing Then
    Set NR = PO103644
    ChDir sPathname & Range("A78").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
Else
    MsgBox "Za delovanje te osvežitve podatkov klikni eno celico v stolpcu - D"
    Exit Sub
End If

PO10365:
If Not Intersect(ActiveCell, PO103651) Is Nothing Then
    Set NR = PO103651
    ChDir sPathname & Range("A10").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
Else
    MsgBox "Za delovanje te osvežitve podatkov klikni eno celico v stolpcu - D"
    Exit Sub
End If

PO10368:
If Not Intersect(ActiveCell, PO103681) Is Nothing Then
    Set NR = PO103681
    ChDir sPathname & Range("A10").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103682) Is Nothing Then
    Set NR = PO103682
    ChDir sPathname & Range("A27").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103684) Is Nothing Then
    Set NR = PO103684
    ChDir sPathname & Range("A69").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103685) Is Nothing Then
    Set NR = PO103685
    ChDir sPathname & Range("A87").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
Else
    MsgBox "Za delovanje te osvežitve podatkov klikni eno celico v stolpcu - D"
    Exit Sub
End If

PO10370:
If Not Intersect(ActiveCell, PO103701) Is Nothing Then
    Set NR = PO103701
    ChDir sPathname & Range("A10").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103702) Is Nothing Then
    Set NR = PO103702
    ChDir sPathname & Range("A31").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
ElseIf Not Intersect(ActiveCell, PO103703) Is Nothing Then
    Set NR = PO103703
    ChDir sPathname & Range("A48").Hyperlinks(1).Address
    sFilename = Application.GetOpenFilename
        If sFilename <> "" Then
            Set wbOp = Workbooks.Open(sFilename)
        End If
    GoTo UpdatePo
Else
    MsgBox "Za delovanje te osvežitve podatkov klikni eno celico v stolpcu - D"
    Exit Sub
End If
        
UpdatePo:
Set ws2 = wbOp.Sheets(1)
For Each x In NR
Set xf = ws2.Range("E9:E" & Range("E65536").End(xlUp).Row).Find(x.Value, Lookat:=xlWhole)
    If Not ws1.Range("J" & x.Row).Value = ws2.Range("O" & xf.Row).Value Then
        ws1.Range("J" & x.Row).Value = ws2.Range("O" & xf.Row).Value
        ws1.Range("G" & x.Row).Value = ws2.Range("A" & xf.Row).Value
        If ws1.Range("J" & x.Row).Value < "5" Or ws1.Range("J" & x.Row).Value = "V" Then
            If ws1.Range("G" & x.Row).Value = "1" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("P" & xf.Row).Value
                ws1.Range("I" & x.Row).Value = Format(Mid(ws2.Range("P" & xf.Row).Comment.Text, 10), "d.m.yyyy")
                ws1.Range("K" & x.Row).Value = ws2.Range("Q" & xf.Row).Value
            ElseIf ws1.Range("G" & x.Row).Value = "2" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("R" & xf.Row).Value
                ws1.Range("I" & x.Row).Value = Format(Mid(ws2.Range("P" & xf.Row).Comment.Text, 10), "d.m.yyyy")
                ws1.Range("K" & x.Row).Value = ws2.Range("S" & xf.Row).Value
            ElseIf ws1.Range("G" & x.Row).Value = "3" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("T" & xf.Row).Value
                ws1.Range("I" & x.Row).Value = Format(Mid(ws2.Range("P" & xf.Row).Comment.Text, 10), "d.m.yyyy")
                ws1.Range("K" & x.Row).Value = ws2.Range("U" & xf.Row).Value
            ElseIf ws1.Range("G" & x.Row).Value = "4" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("V" & xf.Row).Value
                ws1.Range("I" & x.Row).Value = Format(Mid(ws2.Range("P" & xf.Row).Comment.Text, 10), "d.m.yyyy")
                ws1.Range("K" & x.Row).Value = ws2.Range("W" & xf.Row).Value
            End If
        ElseIf ws1.Range("J" & x.Row).Value = "5" Then
            ws1.Range("I" & x.Row).Value = ""
            ws1.Range("K" & x.Row).Value = ""
            If ws1.Range("G" & x.Row).Value = "1" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("P" & xf.Row).Value
            ElseIf ws1.Range("G" & x.Row).Value = "2" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("R" & xf.Row).Value
            ElseIf ws1.Range("G" & x.Row).Value = "3" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("T" & xf.Row).Value
            ElseIf ws1.Range("G" & x.Row).Value = "4" Then
                ws1.Range("H" & x.Row).Value = ws2.Range("V" & xf.Row).Value
            End If
        End If
    End If
Next x
wbOp.Close SaveChanges:=False
End Sub

But I'm tryn to make a code like...

For each worksheet in Thisworkbook.worksheets
For each POnumber
Open workbook
update table
close workbook
Next POnumber
Next Worksheet
MsgBox "Finito"

Any idias?