toevoeging op 'Tabblad kopieren met macro'

[Mcstupid]

Hallo,

Ik gebruik de macro in deze topic.

Maar de code die ik gebruik moet de volgende week aanmaken.

Sub ToevoegenWerkblad()
    Sheets("Opbrengst").Select
    Sheets("Opbrengst").Copy After:=Sheets(Sheets.Count)
    NewSheet = Sheets("Opbrengst").[g69] & " " & WEEKNR(Date) & "(1)"
    x = 0
    Do
        used = False
        x = x + 1
        NewSheet = Left(NewSheet, Len(NewSheet) - 3) & "(" & x & ")"
        For Each ws In Worksheets
            If ws.Name = NewSheet Then used = True
        Next
    Loop Until used = False
    Sheets(Sheets.Count).Name = NewSheet
End Sub

Function WEEKNR(InputDate As Long) As Integer
Dim A As Integer, B As Integer, C As Long, D As Integer
    WEEKNR = 0
    If InputDate < 1 Then Exit Function
    A = Weekday(InputDate, vbSunday)
    B = Year(InputDate + ((8 - A) Mod 7) - 3)
    C = DateSerial(B, 1, 1)
    D = (Weekday(C, vbSunday) + 1) Mod 7
    WEEKNR = Int((InputDate - C - 3 + D) / 7) + 1
End Function

Ik heb al geporbeerd om wat te veranderen maar kan hem niet vinden.

Voorbeeldje
Bekijk bijlage Voorbeeld.xlsm

Is het dan ook mogelijk dat ie het blad kopieert van een verborgen blad?
Want als ik blad 'Opbrengst' verberg, pakt ie de macro niet meer...

En hoe krijg ik die (1) weg?
want als ik & "(1)" weghaal, geeft ie 'Week(1)' aan...

Bij voorbaat dank,

Roelof

 

[ExcelAmateur]

Mcstupid,

Kijk of je er wat mee kunt.

Hij maakt het blad eerst zichtbaar
Dan maakt er een kopie van , zet het als laatste.
Daarna verbergt hij het blad weer.
Het nieuwe blad krijgt een andere naam. (in dit geval "Gelukt")

Misschien kun je het in je code gebruiken?

Opbrengst (2) = de naam van het gekopieeerde blad. (Let op de spatie er tussen)

Sub ToevoegenWerkblad()
 
 Sheets("Opbrengst").Visible = True
 Sheets("Opbrengst").Copy After:=Sheets(Sheets.Count)
 Sheets("Opbrengst").Visible = False
 Sheets("Opbrengst (2)").Name = "Gelukt"
 
End Sub

 

[Warme bakkertje]

Kijk eens of je hiermee verder kan.

Sub ToevoegenWerkblad()
    NewSheet = Sheets("Opbrengst").[a1] & " " & WEEKNR(Date + 7)
    used = False
    For ws = 1 To Worksheets.Count
        If Right(Sheets(ws).Name, 3) = Right(NewSheet, 3) Then used = True
    Next
    If used = False Then
        With Sheets("Opbrengst")
            .Visible = True
            .Copy After:=Sheets(Sheets.Count)
            .Visible = False
        End With
        Sheets(Sheets.Count).Name = NewSheet
    Else
        MsgBox "Dit blad bestaat al": Exit Sub
    End If
End Sub

 

[Mcstupid]

wederom bedankt voor de codes. Doet het perfect!!
Heb de code van WB gebruikt omdat het beter aansluit op wat ik zoek.

Kan ik de code ook activeren met behulp van een knop op bijv. F34 en F35

 

[Warme bakkertje]

Afhankelijk van het soort knop >> Formulieren >> rechtsklikken op knop en macro toewijzen selecteren.
ActiveX >> code zonder Sub en End Sub in het Click-event v/d knop plaatsen.

 

[Mcstupid]

je weet ook alles he!?
alleen ik helaas niet.

Is me wel gelukt om een knop te maken maar verder kan ik er niks mee
'Invoegen > Userform > opdrachtknop'

 

[Warme bakkertje]

Zoals ik het begrijp heb je een userform aangemaakt in VBA en daarop een knop geplaatst. In ontwerpmodus dubbelklik je nu op de aangemaakte knop zodat je in het Click-eventv/d knop terechtkomt. Zet hierin dan de code zonder de bovenste (Sub ....) en de onderste (End Sub) regel.

 

[Mcstupid]

dat klopt inderdaad.

Private Sub CommandButton1_Click()
    NewSheet = Sheets("Opbrengst").[G69] & " " & WEEKNR(Date + 7)
    used = False
    For ws = 1 To Worksheets.Count
        If Right(Sheets(ws).Name, 3) = Right(NewSheet, 3) Then used = True
    Next
    If used = False Then
        With Sheets("Opbrengst")
            .Visible = True
            .Copy After:=Sheets(Sheets.Count)
            .Visible = False
        End With
        Sheets(Sheets.Count).Name = NewSheet
    Else
        MsgBox "Dit blad bestaat al": Exit Sub
    End If
End Sub

Function WEEKNR(InputDate As Long) As Integer
Dim A As Integer, B As Integer, C As Long, D As Integer
    WEEKNR = 0
    If InputDate < 1 Then Exit Function
    A = Weekday(InputDate, vbSunday)
    B = Year(InputDate + ((8 - A) Mod 7) - 3)
    C = DateSerial(B, 1, 1)
    D = (Weekday(C, vbSunday) + 1) Mod 7
    WEEKNR = Int((InputDate - C - 3 + D) / 7) + 1
End Function

Heb nu een in excel een vorm ingevoegd en toegewezen aan de macro. Werkt ook prima!
Maar hoe krijg ik de macro knop in excel?

 

[Warme bakkertje]

Met welke Versie werk je?

 

[Mcstupid]

2007

 

[Warme bakkertje]

Ontwikkelaars >> Invoegen >> ActiveX-besturingselementen >> Knop selecteren en tekenen op je werkblad. In ontwerpmodus dubbelklikken op knop en macro toevoegen zoals op het formulier. Bij de eigenschappen v/d knop de Caption wijzigen in een relevante naam. >> Ontwerpmodus afsluiten.

 

[Mcstupid]

Ontwikkelaars >> Invoegen >> ActiveX-besturingselementen >> Knop selecteren en tekenen op je werkblad. In ontwerpmodus dubbelklikken op knop en macro toevoegen zoals op het formulier. Bij de eigenschappen v/d knop de Caption wijzigen in een relevante naam. >> Ontwerpmodus afsluiten.

Ik kon het maar niet vinden....
Bleek dat ik de ontwikkelaars tabblad had uit staan
Maar het werkt perfect.

En om het af te maken zou het erg mooi zijn als in cel b2 38 staat, dat er in het nieuwe blad in b2 39 staat. Betreft de weeknummer.

 

[Mcstupid]

Dit is de werkende versie

Bekijk bijlage Voorbeeld.xlsm

 

[Warme bakkertje]

Private Sub CommandButton1_Click()
    NewSheet = Sheets("Opbrengst").[G69] & " " & WEEKNR(Date + 7)
    used = False
    For ws = 1 To Worksheets.Count
        If Right(Sheets(ws).Name, 3) = Right(NewSheet, 3) Then used = True
    Next
    If used = False Then
        With Sheets("Opbrengst")
            .Visible = True
            .Copy After:=Sheets(Sheets.Count)
            .Visible = True
        End With
        With Sheets(Sheets.Count)
            .Name = NewSheet
            .[B2] = WEEKNR(Date + 7)
        End With
    Else
        MsgBox "Dit blad bestaat al": Exit Sub
    End If
End Sub

 

[Mcstupid]

Ik heb hem bewerkt en het werkt prima!!!

Ben geholpen!