Naam tabblad met een VBA veranderen

[Jurgen2807]

Hallo,

Als ik op een werkblad de inhoud van een cel verander, bijvoorbeeld D2, dan zou ik graag zien dat de naam van het tabblad automatisch wordt veranderd in de waarde van cel D2. Hoe doe ik dit? Er zijn voorbeelden te vinden, maar daar zitten ook andere criteria aan vast.

Bijgaand een voorbeeldbestandje

Graag jullie hulp

 

[HSV]

Bv.

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address(0, 0) = "D2" And Target <> "" And Target.Count = 1 Then Me.Name = Target
End Sub

 

[edmoor]

Hou er daarbij rekening mee dat de naam van een werkblad maximaal 31 posities lang mag zijn en niet de volgende tekens mag bevatten:

\  /  ?  *  [ ]

Ik zou het dus zo doen:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address(0, 0) = "D2" And Target <> "" And Target.Count = 1 Then
        ActiveSheet.Name = GoedeNaam(Target.Value)
        Target.Value = ActiveSheet.Name
    End If
    Application.EnableEvents = True
End Sub

Function GoedeNaam(st As String) As String
    Dim Fout() As String
    Dim i As Byte
    
    Fout = Split("\,/,?,*,[,]", ",")
    For i = 0 To 5
        st = Replace(st, Fout(i), vbNullString)
    Next i
    
    GoedeNaam = Left(st, 31)
End Function

 

[Jurgen2807]

De code werkt perfect in het voorbeeld wat ik heb toegevoegd.

In mijn eigen prognosemodel werkt deze op 1 tabblad. De overige niet. De fout zit in het deel:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "D2" And Target <> "" And Target.Count = 1 Then Me.Name = Target
End Sub

Wat kan daarvan de reden zijn?

 

[edmoor]

Heb net m'n post in #3 aangepast.

 

[HSV]

Zou Me veranderd in Activesheet wat uithalen denk je?

 

[Jurgen2807]

Dag Ed,

Kan ik je prive mijn bestandje ff mailen? Ik denk dat er een fout in mijn prognosemodel zit. Ik krijg hem niet werkend op tabbladen 1 tm 20. Wel op totaal. Ik heb de hele code van tabblad TOTAAL ook al gekopieerd naar 1, maar dat werkt ook niet.

 

[HSV]

Zet die coderegel in Thisworkbook tussen.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)


End Sub

 

[edmoor]

Wat HSV zegt
Wijzig dan wel ActiveSheet.Name in sh.Name

 

[HSV]

klein beetje aangepast.

If Target.Address(0, 0) = "D2" And Target.Value <> "" And Target.Count = 1 Then Sh.Name = Target

En dan moet je eigenlijk nog controleren of het blad nog niet bestaat.

 

[Jurgen2807]

Dag Harry,

Dan krijg ik nog dezelfde fout :-(.

 

[edmoor]

Die laatste van HSV is een goeie.
Die controle kan je dan in de functie GoedeNaam opnemen.

 

[Jurgen2807]

Je laatste oplossing moet ik nog testen. Ga ik nu doen

 

[Jurgen2807]

Onderstaande code plak ik in Thisworkbook toch?

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Address(0, 0) = "D2" And Target.Value <> "" And Target.Count = 1 Then Sh.Name = Target
End Sub

 

[edmoor]

Zonder alle juiste controles zou dat voldoende moeten zijn. Toch zou ik het dan zo doen:

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    Dim Bladnaam As String
    Application.EnableEvents = False
    If Target.Address(0, 0) = "D2" And Target <> "" And Target.Count = 1 Then
        Bladnaam = GoedeNaam(Target.Value)
        If Bladnaam <> "" Then
            ActiveSheet.Name = Bladnaam
            Target.Value = sh.Name
        Else
            MsgBox "Incorrecte bladnaam"
        End If
    End If
    Application.EnableEvents = True
End Sub

Function GoedeNaam(st As String) As String
    Dim Fout() As String
    Dim i As Integer
    Dim sh As Object
    
    Fout = Split("\,/,?,*,[,]", ",")
    For i = 0 To 5
        st = Replace(st, Fout(i), vbNullString)
    Next i
    
    For Each sh In ActiveWorkbook.Sheets
        If sh.Name = st Then
            st = ""
        End If
    Next sh
    GoedeNaam = Left(st, 31)
End Function

 

[Jurgen2807]

En waar plak ik deze in? In het desbetreffende blad of in Thisworkbook?

 

[HSV]

De code in Thisworkbook.
Uiteraard een mooie code van @edmoor, maar daarmee controleer je volgens mij niet of de naam al bestaat.
Misschien kan Ed deze regel er in opnemen.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Address(0, 0) = "D2" And Target.Value <> "" And Target.Count = 1 Then
 Application.EnableEvents = False
   If Not IsError(Evaluate("'" & Target.Value & "'!A1")) Then
       Target.ClearContents
       MsgBox "bladnaam bestaat al"
   Else
       Sh.Name = Target
   End If
 Application.EnableEvents = True
End If
End Sub

 

[Jurgen2807]

Geheid zal ik iets fout doen, maar het werkt bij mij niet. Als ik de code van Ed in Thisworkbook plak, dan veranderd geen enkele naam.

Kijkt jullie code naar ieder tabblad cel D2?

 

[edmoor]

@HSV:
Die controle zit in de functie GoedeNaam.

 

[Ginger]

Is D2 bij jou toevallig een samengevoegde (Merged) cel?