Tabblad naam macro

[bgoo]

Ik heb een macro die een tabblad maakt en hem vervolgens de naam geeft die in een bepaalde cel staat.

Sub Nieuwebon_lid()

ActiveWorkbook.Unprotect Password:="wsv"
    
Sheets("ZZ NieuweBonLid").Copy , Sheets(Sheets.Count)
      With ActiveSheet
           .Name = Worksheets("ZZZ MENU").Range("F7").Value
           .Range("B3").Value = "Naam: " & Worksheets("ZZZ MENU").Range("F7").Value
           .Range("E3") = Worksheets("ZZZ MENU").Range("F8").Value
      End With
   
ActiveWorkbook.Protect Password:="wsv"

End Sub

Stel dat ik twee tabbladen maak met dezelfde naam gaat hij heel raar doen. Ik ben op zoek naar een code die dan wel de inputnaam pakt, maar daar dan bijvoorbeeld een (2) achter zet.

 

[Niels28]

Zo iets?

Sub Nieuwebon_lid()
Dim Snaam As String
Dim isheet As Integer

ActiveWorkbook.Unprotect Password:="wsv"
    
Sheets("ZZ NieuweBonLid").Copy , Sheets(Sheets.Count)
Snaam = (Worksheets("ZZZ MENU").Range("F7").Value)
For isheet = 1 To Sheets.Count
If Sheets(isheet).Name = Snaam Then
Snaam = (Worksheets("ZZZ MENU").Range("F7").Value & "(2)")
End If
Next
      With ActiveSheet
           .Name = Snaam
           .Range("B3").Value = "Naam: " & Worksheets("ZZZ MENU").Range("F7").Value
           .Range("E3") = Worksheets("ZZZ MENU").Range("F8").Value
      End With
   
ActiveWorkbook.Protect Password:="wsv"

End Sub

Niels

 

[bgoo]

Super! bedankt!

 

[HSV]

Stel je wil het oneindig in plaats van twee.

Sub Nieuwebon_lid()
 ActiveWorkbook.Unprotect Password:="wsv"
   Sheets("ZZ NieuweBonLid").Copy , Sheets(Sheets.Count)
    With ActiveSheet
      With Cells(1, "VI")
        .CurrentRegion.ClearContents
        For Each sh In Sheets
        c0 = c0 & sh.Name & "|"
        Next
    .Resize(Sheets.Count) = WorksheetFunction.Transpose(Split(c0, "|"))
  End With
           .Name = IIf(WorksheetFunction.CountIf(Range("VI1:VI" & Cells(Rows.Count, "VI").End(xlUp).Row), Worksheets("ZZZ MENU").Range("F7").Value & "*") > 0 _
           , Worksheets("ZZZ Menu").Range("F7").Value & " (" & WorksheetFunction.CountIf(Range("VI1:VI" & Cells(Rows.Count, "VI").End(xlUp).Row), Worksheets("ZZZ MENU").Range("F7").Value & "*") + 1 & ")", Worksheets("ZZZ Menu").Range("F7").Value)
           .Range("B3").Value = "Naam: " & Worksheets("ZZZ MENU").Range("F7").Value
           .Range("E3") = Worksheets("ZZZ MENU").Range("F8").Value
           .Cells(1, "VI").CurrentRegion.ClearContents
      End With
  ActiveWorkbook.Protect Password:="wsv"
End Sub

 

[bgoo]

Dankje!

 

[bgoo]

Die laatste geeft echter een error bij currentregion regel 6

 

[HSV]

Die laatste geeft echter een error bij currentregion regel 6

Excuses,

"VI" moet "IV" zijn.

Laatste kolom in Excel 2003.

 

[zapatr]

Wellicht is mijn macro dan mosterd na de maaltijd.
Toch nog maar geplaatst.

Sub Nieuwebon_lid()
Dim aantal As String, t As Integer, x As Integer, v As Integer
'Deze macro is geschreven door Zapatr
aantal = InputBox("Aantal keren dat je een blad wil kopiëren?")
v = Val(aantal)
If v = 0 Then Exit Sub
t = 0
For x = 1 To Sheets.Count
If Right(Sheets(x).Name, 1) = ")" Then
t = t + 1
End If
Next x
For x = 1 To v
Sheets("ZZ NieuweBonLid").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Worksheets("ZZZ MENU").Range("F7").Value & " (" & t + x & ")"
.Range("B3").Value = "Naam: " & Worksheets("ZZZ MENU").Range("F7").Value
.Range("E3") = Worksheets("ZZZ MENU").Range("F8").Value
End With
Next x
End Sub

 

[bgoo]

Excuses,

"VI" moet "IV" zijn.

Laatste kolom in Excel 2003.

Hij deed het prima, totdat ik een programmacode in het blad heb getypt die ik nodig heb. Hij schijnt hiermee te botsen, weet jij mischien wat het is?

With Target
If .Column = 3 And .Value <> "" And IsNumeric(.Value) Then
        .Offset(0, 1).Value = .Offset(0, 1).Value + .Value
        .Value = ""
    End If
  
End With