Trying to rewrite code - help please

[pbt]

I have workbooks left by a former emploee that I am trying to rewrite. There are to many Selects and Activates in them which don't need to be there.

I have done quite a bit of rewriting (with what I have learned on this board) of the some of the modules on my own. Which has increased the time that it took to run it.

But have run into one that is giving me problems.
Original code:

Public Sub AutoLinkAll()
    '//This procedure creates all the necessary links
    '//Declare variables
    Dim shtName As Variant
    Dim cellAdd As String
    Dim ShtCount As Integer
    Dim Count As Byte
    On Error GoTo errHand
        Dim PrgBar As Object
        Set PrgBar = Sheet12.ProgressBar1
        ShtCount = ActiveWorkbook.Sheets.Count - 12
        PrgBar.Visible = True
        Application.ScreenUpdating = False
        PrgBar.Min = 0
        PrgBar.Max = ShtCount
        Count = 1
    '//Turn off screen updating
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Range("D8").Select
    '//Loop through the list of sheet names
Do Until ActiveCell.Value = ""
    Application.ScreenUpdating = True
        PrgBar.Value = Count
        Count = Count + 1
    '//Turn off screen updating
    Application.ScreenUpdating = False
    '//Assign the cell value to variable shtName
    shtName = ActiveCell.Value
    ActiveCell.Offset(1, 0).Select
    '//Test for valid sheet name and send to errHand if not
    Application.Worksheets(shtName).Activate
    Application.Worksheets("BUDGET").Activate
    Range("B10").End(xlToRight).Offset(0, 1).Select
    'Put the name of the sheet in the next empty cell in row 10
    ActiveCell.Value = shtName

    With Selection
        .WrapText = True

    End With
    
    '//Step down one row
    ActiveCell.Offset(1, 0).Select
    '//Input the link to the sheet selected
    ActiveCell.Value = "=" & "'" & shtName & "'" & "!R20"
   
    ActiveCell.Copy
    '//Copy the link to the cells below
    Range(ActiveCell, ActiveCell.Offset(182, 0)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("B10").End(xlToRight).Offset(0, 1).FormulaR1C1 = "ACTUAL"
    Application.Worksheets("CONTROL").Activate
    
Loop

Application.Worksheets("CONTROL").Activate
Application.Calculation = xlCalculationAutomatic
PrgBar.Visible = False
SplashForm2.Show

Exit Sub
errHand:
    If Err.Number = 9 Then
        MsgBox Prompt:="Sheet names must be alpha or alpha numeric." & _
        vbCr & "If you must use numbers enclose them in quotes." & _
        vbCr & "Correct the name, select Clear All and start again.", _
        Title:="                   INVALID NAME"
        
     End If
End Sub

This is how I have attempted to modify the code to get rid of the Select -Activate:

Public Sub AutoLinkAll_2()
    '//This procedure creates all the necessary links
    '//Declare variables
    Dim shtName As Variant
    Dim cellAdd As String
    Dim ShtCount As Integer
    Dim Count As Byte
    Dim ws1 As Worksheet, ws2 As Worksheet '>added
    Set ws1 = Sheets("CONTROL") '>added
    Set ws2 = Sheets("BUDGET") '>added
    On Error GoTo errHand
        Dim PrgBar As Object
        Set PrgBar = Sheet12.ProgressBar1
        ShtCount = ActiveWorkbook.Sheets.Count - 12
        PrgBar.Visible = True
        Application.ScreenUpdating = False
        PrgBar.Min = 0
        PrgBar.Max = ShtCount
        Count = 1
    '//Turn off screen updating
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    With ws1.Range("D8")   '>changed
    '//Loop through the list of sheet names
Do Until ActiveCell.Value = ""
    Application.ScreenUpdating = True
        PrgBar.Value = Count
        Count = Count + 1
    '//Turn off screen updating
    Application.ScreenUpdating = False
    '//Assign the cell value to the variable shtName
    shtName = ActiveCell.Value
    ActiveCell.Offset(1, 0).Select
    '//Test for valid sheet name and send to errHand if not
    Application.Worksheets(shtName).Activate
   ' Application.Worksheets("BUDGET").Activate
    With ws2.Range("B10").End(xlToRight).Offset(0, 1) = shtName '>changed
   ' Range("B10").End(xlToRight).Offset(0, 1).Select
    'Put the name of the sheet in the next empty cell in row 10
    'ActiveCell.Value = shtName

    'With Selection
        .WrapText = True
    End With
    
    '//Step down one row
    ActiveCell.Offset(1, 0).Select
    '//Input the link to the sheet selected
    ActiveCell.Value = "=" & "'" & shtName & "'" & "!R20"
   
    ActiveCell.Copy
    '//Copy the link to the cells below
    Range(ActiveCell, ActiveCell.Offset(182, 0)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("B10").End(xlToRight).Offset(0, 1).FormulaR1C1 = "ACTUAL"
    Application.Worksheets("CONTROL").Activate
Loop

Application.Worksheets("CONTROL").Activate
Application.Calculation = xlCalculationAutomatic
PrgBar.Visible = False
SplashForm2.Show

Exit Sub

errHand:
    If Err.Number = 9 Then
        MsgBox Prompt:="Sheet names must be alpha or alpha numeric." & _
        vbCr & "If you must use numbers enclose them in quotes." & _
        vbCr & "Correct the name, select Clear All and start again.", _
        Title:="                   INVALID NAME"
        
End If
End With
End Sub

Stepping through, once it read this lineApplication.Worksheets(shtName).Activate it goes to the errHand line.

Can't figure it out.

Haven't even tried to figure out the rest of the Selects and Activates yet until this problem is solved.
Harry

 

[SydneyGeek]

This bit will give you trouble:

    With ws1.Range("D8")   '>changed 
    '//Loop through the list of sheet names 
Do Until ActiveCell.Value = "" 
    Application.ScreenUpdating = True 
        PrgBar.Value = Count 
        Count = Count + 1 
    '//Turn off screen updating 
    Application.ScreenUpdating = False 
    '//Assign the cell value to the variable shtName 
    shtName = ActiveCell.Value 
    ActiveCell.Offset(1, 0).Select 
    '//Test for valid sheet name and send to errHand if not 
    Application.Worksheets(shtName).Activate

Because you have usd With to refer to the range and not activated it, ActiveCell won't be ws1.Range("D8"). So you need to change how you refer to the values:

    With ws1.Range("D8")   '>changed 
    '//Loop through the list of sheet names 
Do Until .Value = "" 
    Application.ScreenUpdating = True 
        PrgBar.Value = Count 
        Count = Count + 1 
    '//Turn off screen updating 
    Application.ScreenUpdating = False 
    '//Assign the cell value to the variable shtName 
    shtName = .Value 
    .Offset(1, 0).Select 
    '//Test for valid sheet name and send to errHand if not 
    Application.Worksheets(shtName).Activate

Denis