Run-time error when using VBA to rename worksheets

[thomaslovell]

Please help!!!

Firstly, I am a VBA beginner. I have a Excel (2010) workbook where there are many sheets that need to be renamed according to a list of names on the first sheet named "Testing". The range of names (starting at cell A3) on the first sheet are a part of a Pivot Table. When the information in the Pivot Table is changed, I need to run the macro to change the Worksheet names automatically.

I have used the code below which was posted on another thread for someone requesting similar functionality.

While the below code seems to work fine, when the Pivot Table is updated (using a slicer) and I re-run the macro, I receive the following error message: Run-time error '1004': Application-defined or object-defined error.

Can anybody please tell me why this is happening???

Sub MakeSheetNames()
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim rng1 As Range[/INDENT]
    Dim rng2 As Range
    Dim objDic
    Dim strTmp As String
    Dim strErr As String
    Dim lngCnt As Long
    Set objDic = CreateObject("scripting.dictionary")
    Set ws1 = ThisWorkbook.Sheets("Testing")
    If ws1.Index <> 1 Then
        MsgBox "This code assumes the Set-up sheet is the first worksheet, please reorder sheets and retry"
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set rng1 = ws1.Range(ws1.[a3], ws1.Cells(Rows.Count, "A").End(xlUp))
    lngCnt = 1
    For Each rng2 In rng1
        strTmp = CleanString(rng2.Value)
        If Len(strTmp) > 0 Then
            If Not objDic.exists(strTmp) Then
                lngCnt = lngCnt + 1
                If ThisWorkbook.Sheets.Count < lngCnt Then
                    MsgBox "You only have " & ThisWorkbook.Sheets.Count & " sheets for renaming" & vbNewLine & "Please add more sheets then rerun"
                Else
                    ThisWorkbook.Sheets(lngCnt).Name = strTmp
                    objDic.Add (strTmp), lngCnt
                End If
            Else
                strErr = strErr & strTmp & vbNewLine
            End If
        End If
    Next
    If Len(strErr) > 0 Then MsgBox "These sheets were duplicated:" & vbNewLine & strErr
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub


Function CleanString(strIn As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "[^A-Z\s]+"
        .Global = True
        .IgnoreCase = True
        CleanString = Application.Trim(.Replace(strIn, ""))
    End With
End Function

​

 

[thomaslovell]

Thanks Jerry.

The series name is sourced to: =Testing!$V$4

The series values are: =Testing!$W$4:$AL$4

 

[Jerry Sullivan]

Below is a revised version for you to try...

Sub UpdateSheetNames()
'--Updates Chart Sheet names to match PivotItem list of Athletes' names.

    Dim chtTemplate As Chart, sr1 As Series
    Dim rItems As Range
    Dim lItemCount As Long, lChartCount As Long, lOffset As Long
    Dim i As Integer, iName As Integer

    
    Const sPivotSheetName As String = "Testing"
    Const sDataSheetName As String = "Testing Data"
    Const sFirstChartNameAddress As String = "$V$4"
    Const sFirstChartValuesAddress As String = "$W$4:$AL$4"

    
    On Error GoTo CleanUp
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

'--validate workbook setup
    With ThisWorkbook
        If Not ( _
            .Worksheets(1).Name = sPivotSheetName And _
            .Worksheets(2).Name = sDataSheetName And _
            .Charts.Count > 0) Then
            MsgBox "Workbook is not setup correctly to run UpdateSheetNames macro"
            Exit Sub
        End If
    End With

'--get range listing unique PivotItems- Strings should be Letters and spaces only
    With ThisWorkbook.Sheets(sPivotSheetName)
        Set rItems = .Range(.[a4], .Cells(.Rows.Count, "A").End(xlUp))
        lItemCount = rItems.Count
        If lItemCount < 0 Or lItemCount = 1 And .[a4] = "" Then Exit Sub
    End With

'--add or remove sheets to match the number of Athletes' reports after 2 front sheets
    lChartCount = ThisWorkbook.Charts.Count
    If lChartCount > lItemCount Then
        '--delete extra sheets
        For i = lChartCount To lItemCount + 1 Step -1
            ThisWorkbook.Charts(i).Delete
        Next i
 
    ElseIf lChartCount < lItemCount Then
        '--add worksheets by copying from template
        Set chtTemplate = ThisWorkbook.Charts(1)
        With ThisWorkbook
            lOffset = lChartCount - 1
            For i = 1 To lItemCount - lChartCount
                lOffset = lOffset + 1
                chtTemplate.Copy After:=.Charts(.Charts.Count)
                
                '---update chart data source/title references
                Set sr1 = ActiveChart.SeriesCollection(1)
                With .Sheets(sPivotSheetName)
                    sr1.Name = "=" & .Name & "!" & _
                       .Range(sFirstChartNameAddress).Resize(1).Offset(lOffset).Address
                    sr1.Values = "=" & .Name & "!" & _
                        .Range(sFirstChartValuesAddress).Resize(1).Offset(lOffset).Address
                End With
            Next i
        End With
    End If

'--rename sheets with temporary names
    With ThisWorkbook
        For i = 1 To .Charts.Count
            .Charts(i).Name = "TempName" & i
        Next i
    End With

'--rename sheets from PivotItem List
    With ThisWorkbook
        For iName = 1 To lItemCount
            .Charts(iName).Name = rItems(iName).Value
        Next iName
    End With

CleanUp:
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
    If Err.Description = "Application-defined or object-defined error" And iName > 0 Then
        MsgBox "Unable to rename sheet to: " & rItems(iName).Value, vbExclamation, "Macro stopped"
    End If

    Set chtTemplate = Nothing
    Set rItems = Nothing
    Set sr1 = Nothing
End Sub

 

[thomaslovell]

Jerry... you are the man!

I've had a quick test and it seems to be working perfectly! Thankyou!

As we discussed earlier, if I would like this macro to sync automatically with a pivot table slicer, do I use this code: (Worksheet_PivotTableChangeSync)?

If so, where on macro code do I insert?

If I have 4 slicers for the one pivot table does this change the code required?

Cheers

 

[Jerry Sullivan]

Glad to hear that worked for you.

You could run the code on each change of a any one of the four slicers, but I'm not sure that's the best approach for you.
It would depend on how long it takes for the code to run on each change- which will depend on how many sheets are typically added or deleted.

If it's almost instaneous, then running it on each change could be fine. If there's 2 second or more lag, then it could be annoying when I user intends to modify all 4 slicers before looking at the reports and with each change the application needs to pause.

I'd lean toward having an "Update Reports" button that runs the macro instead of using the Worksheet_PivotTableChangeSync event.

 

[thomaslovell]

Yes, I understand where you are coming from.

I've added a button and it is working perfectly... and looks good too!

I sincerely appreciate your help Jerry.

 

[Jerry Sullivan]

You're very welcome Thomas.