Kopie met een 3-tal vragen

[wivoe]

Geachte deskundigen,

Heb een Hoofdformulier waarin een jaar en maand d.m.v. Kringvelden kan worden gekozen.
De dagnaam, dagnummer en weeknummers zijn daarvan afgeleiden.
Is het mogelijk een kopie van het Hoofdformulier te maken, waar na een klik op de knop:
1. een kopie van het Hoofdformulier wordt gemaakt en het gekozene wordt geplaatst in,
2. een nieuw aan te maken blad dat de naam krijgt van gekozen jaar + maand bv: 2020mei,
3. de formules, opmaak en kolom/regel waarden hetzelfde blijven?

Bij voorbaat dank,

Wim

 

[VenA]

Beetje weinig informatie. Dit is de basis

Sub VenA()
  ActiveSheet.Copy , Sheets(Sheets.Count)
  ActiveSheet.Name = "2020mei"
End Sub

 

[wivoe]

Hallo VenA,

Bedankt voor je snelle reactie, sorry voor mijn onvolledigheid.

De kopie range is van A2 t/m N52

De naam van het nieuwe blad is de naam die gekozen
wordt m.b.v. de Kringvelden Jaar is B4 en Maand is B6
Die beiden kunnen samengevoegd tot '2020mei'.

Er wordt nu met je code een nieuw blad aangemaakt met de naam
van het gekopieerde blad bv. Blad8 wordt Blad8(2), Blad8(3) enz.

Wim

 

[VenA]

Nee hoor. Met mijn code wordt er een blad aangemaakt met de naam '2020mei'. Als je de code nogmaals uitvoert, dan krijg je een foutmelding. Hoewel de vraag niet zo moeilijk is, waarom geen voorbeeldbestand?

 

[JEC.]

Sub VenA()
  ActiveSheet.Copy , Sheets(Sheets.Count)
  ActiveSheet.Name = Range("B4") & Range("B6")
End Sub

 

[wivoe]

Hallo VenA,

Het nieuwe blad krijgt niet (altijd) de naam '2020mei', maar is afhankelijk
van de, in het Hoofdformulier m.b.v. Kringvelden gekozen, jaar en maand.
Het nieuw blad kan dus net zo goed de naam b.v. '2022nov' krijgen.
De keuzes van de Kringvelden, dus Jaar en Maand, staan in resp. B4 en B6

De Kringvelden zelf staan in Rij 1 maar hoeven niet mee gekopieerd te
worden naar het nieuwe blad, vandaar de kopierange A2:N52

Belangrijk is ook dat de formules, opmaak en kolom/regel afstanden
hetzelfde blijven als in het Hoofdformulier.

Wim

 

[HSV]

Test het maar eens.

Sub hsv()
Dim cl As String
With Sheets("hoofdformulier")
cl = .Range("b4") & .Range("b6")
  If IsError(Evaluate("'" & cl & "'!A1")) Then
     .Copy , Sheets(Sheets.Count)
     ActiveSheet.Name = cl
   Else
     MsgBox "Blad " & cl & " bestaat al"
   End If
End With
End Sub

 

[wivoe]

Hallo HSV,

Zoals je al voorstelde hierbij een voorbeeldbestand.

Op blad 2 staat de gevraagde werking.

Groet, Wim

 

[VenA]

Volgens mij heeft @HSV niet om een bestand gevraagd. Heb je de code in #7 getest? Daar is in het bestand niets van terug te vinden ook heb je er niet op gereageerd.

 

[wivoe]

Hallo VenA,

Sorry, je heb gelijk het was HSV niet die daarom vroeg, maar jijzelf.

Heb per ongelijk een verkeerde bijlage gestuurd.

HSV, ik heb je code geprobeerd maar werkte niet zoals ik me voorgesteld had.
Weliswaar kopieerde hij wel het hoofdformulier maar de benaming op
het nieuw Blad was niet correct.
Heb een voorbeeldbestandje meegestuurd en hoop dat het nu de goede is.
Op het gekopieerde Blad staat wat ik er graag als Blad nummer op wil hebben.
Ook de kopieer range wil ik graag van A2:N52 willen hebben.

Sorry voor alle trammelant,

Wim

 

[HSV]

Had direct vermeld dat er een formule in B6 staat en niet "mei" of wat dan ook.

cl = .Range("b4")[COLOR="#FF0000"].Value[/COLOR] & .Range("b6")[COLOR="#FF0000"].Text[/COLOR]

cl = .Range("b4") & [COLOR=#ff0000]Format([/COLOR].Range("b6")[COLOR=#ff0000], "mmm")[/COLOR]

Sub hsv()
Dim cl As String, i As Long
With Sheets("hoofdformulier")
cl = .Range("b4").Value & .Range("b6").Text
  If IsError(Evaluate("'" & cl & "'!A1")) Then
    Sheets.Add(, Sheets(Sheets.Count)).Name = cl
      .Range("a2:n52").Copy
       With Sheets(cl).Cells(2, 1)
         .PasteSpecial xlPasteAll
         .PasteSpecial xlPasteColumnWidths
        End With
      Application.CutCopyMode = False
      Application.ScreenUpdating = False
      For i = 1 To 52
       Sheets(cl).Rows(i).RowHeight = .Rows(i).RowHeight
      Next i
   Else
     MsgBox "Blad " & cl & " bestaat al"
   End If
End With
End Sub

 

[wivoe]

HSV,

Hartelijk dank voor de codes, zal de vraag op opgelost zetten.

Wim