• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Opgelost Naam tabblad aanpassen

  • Onderwerp starter Onderwerp starter Verwijderd lid 501906
  • Startdatum Startdatum
Dit topic is als opgelost gemarkeerd
Status
Niet open voor verdere reacties.
V

Verwijderd lid 501906

Automatisch script om waarde van cel C2 te gebruiken als tabbladnaam.
Deze functie werkt (zie Private Sub)
alleen kunnen er nu dubbele namen ontstaan
daarom wil ik dit script aanpassen (waarde B1 + spatie waarde B2)
C2=(B1 & " " & B2) werkt goed
alleen is C2 niet meer beschikbaar en wil ik de functie gebruiken (B1 & " " & B2) i.p.v. C2
hierbij geld ook nog dat B2 niet de tekst “Leeg” mag bevatten
dus naam aanpassing overslaan.



Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Set Target = Range("C2")
If Target = "" Then Exit Sub
On Error GoTo Badname
ActiveSheet.Name = Left(Target, 31)
Exit Sub
Badname:
MsgBox "Please revise the entry in C2." & Chr(13) _
& "It appears to contain one or more " & Chr(13) _
& "illegal characters." & Chr(13)
Range("C2").Activate
End Sub
 
Een probeerseltje.

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    If Not Target.Address = "$C$2" Then Exit Sub
    If (Range("B1") <> vbNullString) * (Range("B2") <> vbNullString) Then
        myname = Join(Array(Range("B1").Value, Range("B2").Value), " ")
        If Len(myname) >= 31 Then
            If Not Evaluate("isref(" & myname & "!A1)") Then
                ActiveSheet.Name = Left(myname, 31)
            End If
        End If
    Else
        MsgBox "Please revise the entry in B1 & B2." & Chr(13) _
        & "It appears to contain one or more " & Chr(13) _
        & "illegal characters." & Chr(13)
        Application.Goto Range("C2")
    End If
End Sub
 
Aangezien er blijkbaar geen voorbeeldbestandjes meer nodig zijn, probeer deze eens.
 

Bijlagen

Sorry ik weet niet waarom het voorbeeld bestandje er niet bij stond
Emiels voorbeeld bevat een knop en dat is niet wat ik wil
dan kan ik de naam ook handmatig aanpassen
 

Bijlagen

Dus deze macro komt aan alle werkbladen te hangen?
En waar je ook op het werkblad klikt, de naam van het werkblad wordt altijd gewijzigd of blijft hetzelfde als B1 en B2 niet gewijzigd zijn.
Is het dan niet veel beter om een Worksheet_Change event te gebruiken die alleen reageert op het wijzigen van de cellen B1 en B2 waarbij ook gecontroleerd wordt of er toevallig al zo'n werkblad bestaat? En een generieke procedure te gebruiken die vanuit de Worksheet_Change event wordt aangeroepen?

Je zou het ook met één gebeurtenisprocedure kunnen oplossen:
Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim newname As String
    If Target.Address = "$B$1" Or Target.Address = "$B$2" Then
        newname = Left(Sh.Range("B1") & " " & Sh.Range("B2"), 31)
        For Each mysheet In ActiveWorkbook.Sheets
            If mysheet.Name = newname Then
                MsgBox "Sheet " & newname & " already exists." & vbCrLf & _
                "Please review your entries in B1 and/or B2", vbCritical, "Warning"
                Exit Sub
            End If
        Next
        Sh.Name = newname
    End If
End Sub
 
Laatst bewerkt:
Verander
Code: 
Set Target = Range("C2")
in
Code: 
Set Target = Range("B1" & " " & "B2")
 
AHulpje zei:
Dus deze macro komt aan alle werkbladen te hangen?
En waar je ook op het werkblad klikt, de naam van het werkblad wordt altijd gewijzigd of blijft hetzelfde als B1 en B2 niet gewijzigd zijn.
Is het dan niet veel beter om een Worksheet_Change event te gebruiken die alleen reageert op het wijzigen van de cellen B1 en B2 waarbij ook gecontroleerd wordt of er toevallig al zo'n werkblad bestaat? En een generieke procedure te gebruiken die vanuit de Worksheet_Change event wordt aangeroepen?
Klik om te vergroten...

Ja dat klopt volledig.
Later wil ik daar nog een uitzondering op inbouwen voor een "tabblad X" "tabblad Y" en alle verborgen tabbladen.
 
Je had hem in je uitleg geschreven zonder de aanhalingstekens op de juiste plaats, dus vandaar mijn opmerking...
 
Warme bakkertje zei:
Een probeerseltje.

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    If Not Target.Address = "$C$2" Then Exit Sub
    If (Range("B1") <> vbNullString) * (Range("B2") <> vbNullString) Then
        myname = Join(Array(Range("B1").Value, Range("B2").Value), " ")
        If Len(myname) >= 31 Then
            If Not Evaluate("isref(" & myname & "!A1)") Then
                ActiveSheet.Name = Left(myname, 31)
            End If
        End If
    Else
        MsgBox "Please revise the entry in B1 & B2." & Chr(13) _
        & "It appears to contain one or more " & Chr(13) _
        & "illegal characters." & Chr(13)
        Application.Goto Range("C2")
    End If
End Sub
Klik om te vergroten...


Helaas werkt niet
 
Waarom een loop over alle werkbladen in het bestand gebruiken als dit voldoende is ???

Code: 
    newname = Left(Sh.Range("B1") & " " & Sh.Range("B2"), 31)
    If Evaluate("isref(" & newname & "!A1)") Then
        MsgBox "Sheet " & newname & " already exists." & vbCrLf & _
            "Please review your entries in B1 and/or B2", vbCritical, "Warning"
        Exit Sub
    End If
 
Helaas werkt niet
Klik om te vergroten...
Ter informatie werkt mijn code wel, je moet wel cel C2 selecteren om de code te starten.
Tot hiertoe heb je op nog geen enkel moment duidelijk uitgelegd wat nu eigenlijk de bedoeling is.
Moet dit werken voor 1 blad of voor alle bladen??
Met welke handeling moet de Event Code gestart worden??
Enz.....??
 
Probeer het eens zo, zie Function DoetMee voor de uitgezonderde werkbladen:
 

Bijlagen

Warme bakkertje zei:
Waarom een loop over alle werkbladen in het bestand gebruiken als dit voldoende is ???

Code: 
    newname = Left(Sh.Range("B1") & " " & Sh.Range("B2"), 31)
    If Evaluate("isref(" & newname & "!A1)") Then
        MsgBox "Sheet " & newname & " already exists." & vbCrLf & _
            "Please review your entries in B1 and/or B2", vbCritical, "Warning"
        Exit Sub
    End If
Klik om te vergroten...

Dit geeft de volgende foutmelding

Methode Range van Object_worksheet is mislukt.
 
OMG man post een bestand met de codes erin waarvan jij denkt waar ze moeten staan en hoe ze zouden moeten werken want nu worden er allerlei suggesties gedaan door meer dan bereidwillige helpers en het enige dat wij van jou horen is "HET WERKT NIET"
 
Dan doe je iets niet goed.:(
Heb je je eigen code wel verwijderd? De enige code die je voor mijn oplossing nodig hebt plaats je in de ThisWorkbook module, alle andere code voor het hernoemen van de werkbladen moet je verwijderen:
Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim newname As String
    If Target.Address = "$B$1" Or Target.Address = "$B$2" Then
        newname = Left(Sh.Range("B1") & " " & Sh.Range("B2"), 31)
        For Each mysheet In ActiveWorkbook.Sheets
            If mysheet.Name = newname Then
                MsgBox "Sheet " & newname & " already exists." & vbCrLf & _
                "Please review your entries in B1 and/or B2", vbCritical, "Warning"
                Exit Sub
            End If
        Next
        If DoetMee(Sh.Name) Then Sh.Name = newname
    End If
End Sub

Function DoetMee(werkblad)
    'Voeg hier alle werkbladen toe die NIET meedoen
    DoetMee = InStr("DezeNiet,Totaal", werkblad) = 0
End Function
Je kunt eventueel nog wat code toevoegen om te controleren of B1 en B2 beide zijn gevuld.
 
Warme bakkertje zei:
OMG man post een bestand met de codes erin waarvan jij denkt waar ze moeten staan en hoe ze zouden moeten werken want nu worden er allerlei suggesties gedaan door meer dan bereidwillige helpers en het enige dat wij van jou horen is "HET WERKT NIET"
Klik om te vergroten...

Sorry hoor
Ik ben heel dankbaar voor alle hulp

Als ik niet duidelijk genoeg was
het bestand dat ik vergeten was toe te voegen werkt !
Alleen kan ik cel C2 straks niet gebruiken.
Het bestand heb ik in tweede instantie bijgevoegd

Hoe ik jouw script ook probeer
de namen van de tabbladen worden niet aangepast
 
AHulpje zei:
Dan doe je iets niet goed.:(
Heb je je eigen code wel verwijderd? De enige code die je voor mijn oplossing nodig hebt plaats je in de ThisWorkbook module, alle andere code voor het hernoemen van de werkbladen moet je verwijderen:
Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim newname As String
    If Target.Address = "$B$1" Or Target.Address = "$B$2" Then
        newname = Left(Sh.Range("B1") & " " & Sh.Range("B2"), 31)
        For Each mysheet In ActiveWorkbook.Sheets
            If mysheet.Name = newname Then
                MsgBox "Sheet " & newname & " already exists." & vbCrLf & _
                "Please review your entries in B1 and/or B2", vbCritical, "Warning"
                Exit Sub
            End If
        Next
        If DoetMee(Sh.Name) Then Sh.Name = newname
    End If
End Sub

Function DoetMee(werkblad)
    'Voeg hier alle werkbladen toe die NIET meedoen
    DoetMee = InStr("DezeNiet,Totaal", werkblad) = 0
End Function
Je kunt eventueel nog wat code toevoegen om te controleren of B1 en B2 beide zijn gevuld.
Klik om te vergroten...

Ja ik heb eerst alles verwijderd
jouw script toegevoegd
opgeslagen
en daarna geopend en de cellen aangepast
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan