PDA

View Full Version : ms progress bar 6.0



epd
03-29-2012, 03:39 PM
Hi,

i have tried looking at making a progress bar for my userform using labels and frames but could not work out how to do it. Now i have started looking into the standard ms progress bar thinking i could work out how to use that instead, but i cant. threads i have read up on have been no use to me as i couldnt understand what it was doing nor how to impliment it into my code.

my code (in userform1):

Private Sub ProgressBar1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
End Sub
Private Sub UserForm_activate()
'Open Userform on same screen as workbook and center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With

'Unprotect Workbook
ThisWorkbook.Worksheets("Cover Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect Password:="password"

'PDF HYPERLINKING

Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("U21:U2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02. PDFs\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".pdf"
shortname = ".pdf"

If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If

Next cll



'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "-" to colour black
Dim cell As Range, iRange As Range
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".pdf" to underline
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select

'Close USEHYPERLINKINGNOTEPDF
Unload UserForm1

'Protect Workbook
ThisWorkbook.Worksheets("Cover Page").protect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect Password:="password"
ThisWorkbook.Worksheets("L - Layout").protect Password:="password"
End Sub



What i am trying to do:
the run pdf hyperlinking routine is where i want the progress bar to look. that routine loops through about 2000 cells and i would like the progress bar to show me it's progress through that routine.

I have also posted this question here (http://www.mrexcel.com/forum/showthread.php?p=3100010#post3100010)

i am using excel 2007

epd
03-29-2012, 05:36 PM
i have been playing around with my code and have this atm




Private Sub UserForm_activate()


'Open Userform on same screen as workbook and
center
With UserForm1

.StartUpPosition = 0
.Left = Application.Left + (0.5 *
Application.Width) - (0.5 * .Width)
.Top = Application.Top
+ (0.5 * Application.Height) - (0.5 * .Height)
End
With

'Text

Label2 = "Hyperlinking, please wait..."


'Button invisible

CommandButton2.Visible = False


'Unprotect Workbook
ThisWorkbook.Worksheets("Cover
Page").Unprotect Password:="password"

ThisWorkbook.Worksheets("D - Documentation").Unprotect
Password:="password"
ThisWorkbook.Worksheets("E -
Electrical").Unprotect Password:="password"

ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect
Password:="password"
ThisWorkbook.Worksheets("G - General
Arrangement").Unprotect Password:="password"

ThisWorkbook.Worksheets("L - Layout").Unprotect
Password:="password"


'PDF HYPERLINKING



ProgressBar1.Min = 1
ProgressBar1.Max =
2018
For Count = 1 To 2018
ProgressBar1.Value =
Count




Me.Repaint


'select cells and clear values so removed PDFs become
unclickable

ActiveSheet.Range("U21:U2039").Select

Selection.ClearContents


'Run PDF Hyperlinking
Set fs =
CreateObject("Scripting.FileSystemObject")
For Each cll In
Range("U21:U2039").Cells
fname =
"I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02.
PDFs\"
shortname =
""
For Each cel In Cells(cll.Row,
"H").Resize(,
5).Cells

fname = fname &
cel.Value

shortname = shortname &
cel.Value
Next
cel
fname = fname &
".pdf"
shortname =
".pdf"


If fs.FileExists(fname)
Then

cll.Parent.Hyperlinks.Add cll, fname, , ,
shortname

Else

cll.Value = "-"
End
If

Count = Count +
1
ProgressBar1.Value = Count


Next
cll

Next




'Select cells and make all text blue,
underlined and "Calibri" text style

ActiveSheet.Range("U21:U2039").Select

Selection.Font.ColorIndex = 5
Selection.Font.Name =
"Calibri"


'Change text that contains "-" to colour black
Dim cell As
Range, iRange As Range
Set iRange =
Range("U21:U2039")
If iRange Is Nothing Then Exit
Sub
Application.EnableEvents = False

For Each cell In iRange
With cell

Select Case True
Case InStr(.Value2, "-") >
0
.Font.ColorIndex = 0
End
Select
End With
Next
cell
Application.EnableEvents = True


'Change text that contains ".pdf" to
underline
Set iRange =
Range("U21:U2039")
If iRange Is Nothing Then Exit
Sub
Application.EnableEvents = False

For Each cell In iRange
With cell

Select Case True
Case InStr(.Value2, ".pdf") >
0
.Font.Underline =
xlUnderlineStyleSingle
End Select

End With
Next cell

Application.EnableEvents = True


'select cells and clear values so removed PDFs become
unclickable
ActiveSheet.Range("U121:W121, U222:W222,
U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929,
U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535,
U1636:W1636, U1737:W1737, U1838:W1838,
U1939:W1939").Select

Selection.ClearContents

'Select
cells at top"
Cells(21,
1).Select

'Protect
Workbook
ThisWorkbook.Worksheets("Cover Page").protect
Password:="password"
ThisWorkbook.Worksheets("D -
Documentation").protect Password:="password"

ThisWorkbook.Worksheets("E - Electrical").protect
Password:="password"
ThisWorkbook.Worksheets("F - Process
Flow & P&ID").protect Password:="password"

ThisWorkbook.Worksheets("G - General Arrangement").protect
Password:="password"
ThisWorkbook.Worksheets("L -
Layout").protect Password:="password"


'Text
Label2 = "Hyperlinking
completed. Press 'OK' to continue."


'Button invisible
CommandButton2.Visible =
True




End Sub


Private Sub CommandButton2_Click()


'Close userform1
Unload
UserForm1


End Sub



the progress bar is working BUT i am coming up with and error once my loop has gone through. the error is happening at line

ProgressBar1.Value = Count

after the line

Count = Count + 1

i assume it is because the progress bar is finished and it doenst know what to do next?

i tried to use an if statement like

if count = 2018 then
move on to 'Select cells and make all text blue, underlined and "Calibri" text style etc
else
next

but then the routine says to me for without next.

epd
03-29-2012, 06:46 PM
ok, some progress

i now have 4 progress bars on the 1 userform

progressbarpdf
progressbardwg
progressbardir
progressbaroverall

the problems i am encountering are:

once a progress bar reaches it's max (ie: progressbarpdf) how do i get it to
1. stop trying to add 1 to the count and finish
2. keep the progress bar "full" while the routine now runs onto the next progress bar

and

my progressbaroverall isnt continuing from it's last count, it resets back to 1 everytime a new progress bar starts. i gather this is because i am using the word count for the individual progress bars as well as the overall one. is it possible to have multiple counts in the one routine without the program thinking they are the same thing?

here is my code thus far.


Private Sub UserForm_activate()
'Open Userform on same screen as workbook and center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With

'Button invisible
CommandButton2.Visible = False

'Unprotect Workbook
ThisWorkbook.Worksheets("Cover Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect Password:="password"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''

'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6054
''ProgressBar1.Value = Count

'ProgressBarpdf
ProgressBarpdf.Min = 1
ProgressBarpdf.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count

'PDF HYPERLINKING

'Repaint Window
Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("U21:U2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02. PDFs\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".pdf"
shortname = ".pdf"

If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If

Count = Count + 1
ProgressBarpdf.Value = Count
Count = Count + 1
ProgressBaroverall.Value = Count

Next cll

Next

'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "-" to colour black
Dim cell As Range, iRange As Range
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".pdf" to underline
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBarpdf
ProgressBarpdf.Value = 2018
'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6054
ProgressBaroverall.Value = 2018

'ProgressBardwg
ProgressBardwg.Min = 1
ProgressBardwg.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count

'DWG HYPERLINKING

'Repaint Window
Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("V21:V2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("V21:V2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".dwg"
shortname = ".dwg"

If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Count = Count + 1
ProgressBardwg.Value = Count
Count = Count + 1
ProgressBaroverall.Value = Count

Next cll

Next

'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("V21:V2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "PDF Unavailable" to colour black
'Dim cell As Range, iRange As Range
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".dwg" to underline
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dwg") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''
'ProgressBardwg
ProgressBardwg.Value = 2018
'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6054
ProgressBaroverall.Value = 4036

'ProgressBardir
ProgressBardir.Min = 1
ProgressBardir.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'DWG HYPERLINKING
'Repaint Window
Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W21:W2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "U").Value = ".pdf", ".dir", "-")

If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Next cll

For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "V").Value = ".dwg", ".dir", "-")

If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Count = Count + 1
ProgressBardir.Value = Count
Count = Count + 1
ProgressBaroverall.Value = Count

Next cll

Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("W21:W2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "-" to colour black
''Dim cell As Range, iRange As Range
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".dir" to underline
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dir") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W121:W121, W222:W222, W323:W323, W424:W424, W525:W525, W626:W626, W727:W727, W828:W828, W929:W929, W1030:W1030, W1131:W1131, W1232:W1232, W1333:W1333, W1434:W1434, W1535:W1535, W1636:W1636, W1737:W1737, W1838:W1838, W1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select

'Protect Workbook
ThisWorkbook.Worksheets("Cover Page").protect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect Password:="password"
ThisWorkbook.Worksheets("L - Layout").protect Password:="password"
'Text
Label2 = "Hyperlinking completed. Press 'OK' to continue."

'Button invisible
CommandButton2.Visible = True
End Sub
Private Sub CommandButton2_Click()
'Close userform1
Unload UserForm1
End Sub

epd
03-29-2012, 08:39 PM
alright, i have worked it out. i found the .width = complete command.

here is my code.


Private Sub UserForm_activate()
'Open Userform on same screen as workbook and center
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With

'Button invisible
CommandButton2.Visible = False

'Unprotect Workbook
ThisWorkbook.Worksheets("Cover Page").Unprotect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").Unprotect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").Unprotect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").Unprotect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").Unprotect Password:="password"
ThisWorkbook.Worksheets("L - Layout").Unprotect Password:="password"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''

'ProgressBaroverall
ProgressBaroverall.Min = 1
ProgressBaroverall.Max = 6056

'ProgressBarpdf
ProgressBarpdf.Min = 1
ProgressBarpdf.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count

'PDF HYPERLINKING

'Repaint Window
Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U21:U2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("U21:U2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\02. PDFs\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".pdf"
shortname = ".pdf"

If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If

If ProgressBarpdf.Value = 2018 Then
ProgressBarpdf.Width = Completed
Else
Count = Count + 1
ProgressBarpdf.Value = Count
End If
ProgressBaroverall.Value = Count

Next cll

Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("U21:U2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "-" to colour black
Dim cell As Range, iRange As Range
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".pdf" to underline
Set iRange = Range("U21:U2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".pdf") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''

'ProgressBardwg
ProgressBardwg.Min = 1
ProgressBardwg.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count

'DWG HYPERLINKING

'Repaint Window
Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("V21:V2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cll In Range("V21:V2039").Cells
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
shortname = ""
For Each cel In Cells(cll.Row, "H").Resize(, 5).Cells
fname = fname & cel.Value
shortname = shortname & cel.Value
Next cel
fname = fname & ".dwg"
shortname = ".dwg"

If fs.FileExists(fname) Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
If ProgressBardwg.Value = 2018 Then
ProgressBardwg.Width = Completed
Else
Count = Count + 1
ProgressBardwg.Value = Count
End If
ProgressBaroverall.Value = Count + 2018

Next cll

Next

'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("V21:V2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "PDF Unavailable" to colour black
'Dim cell As Range, iRange As Range
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".dwg" to underline
Set iRange = Range("V21:V2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dwg") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("U121:W121, U222:W222, U323:W323, U424:W424, U525:W525, U626:W626, U727:W727, U828:W828, U929:W929, U1030:W1030, U1131:W1131, U1232:W1232, U1333:W1333, U1434:W1434, U1535:W1535, U1636:W1636, U1737:W1737, U1838:W1838, U1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''

'ProgressBardir
ProgressBardir.Min = 1
ProgressBardir.Max = 2018
For Count = 1 To 2018
ProgressBarpdf.Value = Count
'DWG HYPERLINKING
'Repaint Window
Me.Repaint

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W21:W2039").Select
Selection.ClearContents

'Run PDF Hyperlinking
fname = "I:\Drafting\As Built\4CP - Pinkenba\E - Electrical\Zircon Plant\"
For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "U").Value = ".pdf", ".dir", "-")

If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
Next cll

For Each cll In Range("W21:W2039").Cells
shortname = ".dir"
Cells(cll.Row, "W").Value = IIf(Cells(cll.Row, "V").Value = ".dwg", ".dir", "-")

If Cells(cll.Row, "W").Value = ".dir" Then
cll.Parent.Hyperlinks.Add cll, fname, , , shortname
Else
cll.Value = "-"
End If
If ProgressBardir.Value = 2018 Then
ProgressBardir.Width = Completed
Else
Count = Count + 1
ProgressBardir.Value = Count
End If
ProgressBaroverall.Value = Count + 4036

Next cll

Next
'Select cells and make all text blue, underlined and "Calibri" text style
ActiveSheet.Range("W21:W2039").Select
Selection.Font.ColorIndex = 5
Selection.Font.Name = "Calibri"

'Change text that contains "-" to colour black
''Dim cell As Range, iRange As Range
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, "-") > 0
.Font.ColorIndex = 0
End Select
End With
Next cell
Application.EnableEvents = True

'Change text that contains ".dir" to underline
Set iRange = Range("W21:W2039")
If iRange Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In iRange
With cell
Select Case True
Case InStr(.Value2, ".dir") > 0
.Font.Underline = xlUnderlineStyleSingle
End Select
End With
Next cell
Application.EnableEvents = True

'select cells and clear values so removed PDFs become unclickable
ActiveSheet.Range("W121:W121, W222:W222, W323:W323, W424:W424, W525:W525, W626:W626, W727:W727, W828:W828, W929:W929, W1030:W1030, W1131:W1131, W1232:W1232, W1333:W1333, W1434:W1434, W1535:W1535, W1636:W1636, W1737:W1737, W1838:W1838, W1939:W1939").Select
Selection.ClearContents

'Select cells at top"
Cells(21, 1).Select

'Protect Workbook
ThisWorkbook.Worksheets("Cover Page").protect Password:="password"
ThisWorkbook.Worksheets("D - Documentation").protect Password:="password"
ThisWorkbook.Worksheets("E - Electrical").protect Password:="password"
ThisWorkbook.Worksheets("F - Process Flow & P&ID").protect Password:="password"
ThisWorkbook.Worksheets("G - General Arrangement").protect Password:="password"
ThisWorkbook.Worksheets("L - Layout").protect Password:="password"
'Text
Label2 = "Hyperlinking completed. Press 'OK' to continue."

'Button invisible
CommandButton2.Visible = True
End Sub
Private Sub CommandButton2_Click()
'Close userform1
Unload UserForm1
End Sub




all i have to work out now is how to keep the .pdf bar full when it goes onto the .dwg bar instead of going blank.