Werkbladen kopieren en renamen

[thevbadude]

Beste lezers,

Ik ben bezig met een workbook waarin ik een template meerdere malen wil kopiëren en renamen. Op het moment heb ik dit:

Public Sub SheetCopy()
Dim Sh As Worksheet, TemplateSh As Worksheet
Dim ShNum As Integer, HighestNum As Integer
Dim SheetCoreName As String
Dim i As Long

' geef naam blad aan:
SheetCoreName = "test"

' template naam:
Set TemplateSh = Sheets("blad1")


' aangeven volgende nummer
For Each Sh In Worksheets
If InStr(1, Sh.Name, SheetCoreName) = 1 Then
    ShNum = Val(Right(Sh.Name, Len(Sh.Name) - Len(SheetCoreName)))
    If ShNum > HighestNum Then HighestNum = ShNum
End If
Next Sh

' copy template

 For i = 1 To Range("f11")
  TemplateSh.Copy After:=Sheets(Sheets.Count)
Next


' zichtbaar maken
ActiveSheet.Visible = xlSheetVisible

' rename
ActiveSheet.Name = SheetCoreName & HighestNum + 1

End Sub

hij kopieert de werkbladen nu wel echter de benoeming gaat nog niet helemaal lekker (zou : test 1, test 2, test 3 etc. moeten zijn). Is het ook mogelijk om hier een Worksheet.change.event van te maken? Dus wanneer in f11 een ander aantal word ingevoerd hij automatisch de tabbladen die teveel zijn verwijderd of bijmaakt? Alvast bedankt voor het meedenken!

Greetz,

thedude

 

[Niels28]

zo iets?

Private Sub Worksheet_Change(ByVal Target As Range)

Application.DisplayAlerts = False

If Target.Address = "$F$11" Then
    If ThisWorkbook.Sheets.Count > Target.Value + 1 Then
        For sh = Target.Value + 2 To Sheets.Count
            Sheets(sh).Delete
        Next
    End If
    
    Application.DisplayAlerts = True
    
    For sh = Sheets.Count To Target.Value
        Sheets(1).Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Test" & Sheets.Count - 1
    Next
End If


End Sub

Niels

 

[thevbadude]

Hey niels (wederom de redder in nood:d)! nog niet helemaal, misschien dat het helpt: Eerste tabblad "algemeen" staat in f11 de waarde, de template is het 5de blad "test" , deze 5 tabbladen dienen altijd te blijven, afhankelijk van de ingevulde waarde in f11 dienen tabblad 6 (test 2), tabblad 7 (test 3) etc te worden aangemaakt.

 

[Niels28]

een beetje met de getallen spelen:

Private Sub Worksheet_Change(ByVal Target As Range)

Application.DisplayAlerts = False

If Target.Address = "$F$11" Then
    If ThisWorkbook.Sheets.Count > Target.Value + 5 Then
        For sh = Target.Value + 6 To Sheets.Count
            Sheets(sh).Delete
        Next
    End If
    
    Application.DisplayAlerts = True
    
    For sh = Sheets.Count To Target.Value + 4
        Sheets(5).Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Test" & Sheets.Count - 4
    Next
End If


End Sub

Niels

 

[Niels28]

voeg om het knipperen van het scherm tegen te gaan boven in de macro het volgende toe:

application.screenupdating = false

Niels

 

[thevbadude]

Heb deze middag van alles geprobeerd maar ik kom er niet helemaal uit. op het moment dat ik bijv 5 sheets heb laten aanmaken en terug wil naar 3 geeft hij aan dat het buiten bereik ligt.

 

[snb]

Het heeft geen zin gebruik te maken van de index van werkbladen want die veranderen automatisch als er een werkblad wordt toegvoegd / verwijderd.

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$F$11" Then
      for j=1 to target.value
         sheets("test").copy ,sheets(sheets.count)
         activesheet.name="Test_" & sheets.count
      next
    end if
End Sub

 

[thevbadude]

thx Snb de code werkt opzich goed alleen hierbij ondervind ik hetzelfde probleem. Wanneer ik f11 een andere waarde wil geven worden er een x aantal tabbladen achter geplaatst zonder dat de vorige verwijderd worden.

edit: zit nu te kijken om iets als dit werkend er tussen te krijgen maar het wil niet echt vorderen

Dim i As Long

Application.DisplayAlerts = False

For i = 1 to Worksheets.Count
If Worksheets(i).Name Like “Test*” Then Worksheets(i).Delete
Next i

 

[snb]

Sub M_snb()
   For Each sh In Sheets
     If sh.Name <> "niet" Then c00 = c00 & "|" & sh.Name
   Next
   Sheets(Split(Mid(c00, 2), "|")).Delete
End Sub

Is het niet verstandiger alle werkbladen met 'Test' in de naam leeg te maken (clearcontents) ?
Alleen als het overblijvende aantal te klein is , bladen toevoegen.
Maar waarom ook niet een vrij groot aantal werkbladen standaard opnemen, die je in het ene geval wel gebruikt en in het andere niet ?
Dan hoef je alleen maar indien nodig die werkbladen 'leeg' te maken.

 

[thevbadude]

Misschien wel een beter idee om de bladen gewoon aan te maken en dan met een macro te verbergen of zichtbaar te maken.

Op het moment heb ik dit werkend voor 4 tabbladen echter denk ik dat er een makkelijkere manier is waarbij ik niet alle 30 tabbladen (cases) hoef uit te typen.

Private Sub worksheet_change(ByVal target As Excel.Range)
    Select Case Worksheets("Algemeen").Range("f11").Value
    Case "1"
     Worksheets("blad1").Visible = True
        Worksheets("blad2").Visible = False
        Worksheets("blad3").Visible = False
          Worksheets("blad4").Visible = False
    Case "2"
        Worksheets("blad1").Visible = True
        Worksheets("blad2").Visible = True
        Worksheets("blad3").Visible = False
          Worksheets("blad4").Visible = False
    Case "3"
        Worksheets("blad1").Visible = True
        Worksheets("blad2").Visible = True
        Worksheets("blad3").Visible = True
          Worksheets("blad4").Visible = False
    Case "4"
        Worksheets("blad1").Visible = True
        Worksheets("blad2").Visible = True
        Worksheets("blad3").Visible = True
        Worksheets("blad4").Visible = True
    End Select
End Sub

iemand misschien nog een idee?

 

[snb]

Lijkt me voldoende:

Sub M_snb()
  For j = 1 To 30
    Sheets("Test" & j).Visible = IIf(j > Cells(11, 5), 2, -1)
  Next
End Sub

 

[thevbadude]

Bovenstaande code doet het helaas ook niet. Heb hem uiteindelijk maar gewoon uitgetikt toch bedankt!