Verzenden selectie tabbladen via UserForm

[Excellerend]

Beste Forumleden,

Ik heb een vraagstuk waar ik met mijn zeer beperkte VBA-kennis niet uit kom.

Ik heb een Excel bestand bedoeld als weekrapport (versimpelde versie, zie bijlage) waarin 7 tabbladen zijn opgenomen, voor elke dag van de week 1. (Genaamd: "Maandag", "Dinsdag", "Woensdag", etc.)
Nu moet het personeel de keuze krijgen welke dag (dus welk tabblad) zij willen printen of verzenden per email (in Excel of in PDF), heeft o.a. te maken met verschillende opdrachtgevers.
Ik heb daarvoor een UserForm ("Afdrukkeuze") gemaakt. Op de Form staat voor elke dag een CheckBox welke allemaal zijn hernoemd. (b.v. de checkbox voor maandag = "CB_Maandag")

Ik heb alleen de optie verzenden-als-Excel opgenomen in de versimpelde versie. Hiervoor gebruik ik (uiteraard) de code van Ron de Bruin.

Ron heeft een mooie code om meerdere tabbladen te verzenden via de Array optie:

With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        
        .Sheets(Array("Maandag", "Dinsdaf")).Copy
    
    End With

Nu heb ik deze code geprobeerd om te bouwen naar mijn wens:

With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow    
       
        If Me.CB_Maandag = True Then
        .Sheets("Maandag").Copy
        End If
        
        If Me.CB_Dinsdag = True Then
        .Sheets("Dinsdag").Copy          '<-- Enkel de laatste wordt gekopieerd

        End If
    End With

Enkel geeft dit niet het gewenst resultaat. Na het kopiëren van het eerste aangevinkte tabblad moet het volgend aangevinkte tabblad erna gekopieerd worden in hetzelfde bestand (iets met CopyAfter en een Loop?)

Ik kom er niet uit, ondanks een aantal uren stoeien, kunnen jullie mij aan het gewenste resultaat helpen?

Alvast bedankt,
Peter

Bijlage: Bekijk bijlage Afdrukkeuze via Userform.xlsm

 

[MDN111]

Dag Excellerend !

Blijkbaar wordt een vorige Copy overschreven als men nadien nog een Copy uitvoert. Vandaar dat alleen de laatste sheet gekopieerd wordt.

Aan de code van Ron De Bruin te zien, worden de sheets in een enkele beweging gekopieerd aan de hand van een array waarin de sheetnamen vermeld staan. Als men dus de geselecteerde sheets eerst onderbrengt in een array en dan de Copy uitvoert worden alle geselecteerde sheets gekopieerd.

Hierna de gewijzigde code:

Private Sub Verzenden_PDF_Click()

'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim TheActiveWindow As Window
    Dim TempWindow As Window
    
    Dim myControl As Control
    Dim myString As String
    Dim myArray
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook

    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        
        For Each myControl In Me.Controls
            If Left(myControl.Name, 3) = "CB_" Then
                If myControl Then
                    myString = myString & Mid(myControl.Name, 4) & "*"
                End If
            End If
        Next
        
        myString = Left(myString, Len(myString) - 1)
        myArray = Split(myString, "*")
        .Sheets(myArray).Copy

    End With
        
    'Close temporary Window
    TempWindow.Close

    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2013
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    '    'Change all cells in the worksheets to values if you want
    '    For Each sh In Destwb.Worksheets
    '        sh.Select
    '        With sh.UsedRange
    '            .Cells.Copy
    '            .Cells.PasteSpecial xlPasteValues
    '            .Cells(1).Select
    '        End With
    '        Application.CutCopyMode = False
    '        Destwb.Worksheets(1).Select
    '    Next sh

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = ""
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Afdrukkeuze_frm.Hide
    
End Sub

Grtz,
MDN111.

 

[Excellerend]

Beste MDN111,

Je oplossing werkt perfect, waarvoor dank.
Enkel na het kopiëren van de code van het vereenvoudigde voorbeeldbestand naar mijn daadwerkelijke sheet geeft de code een fout.

Ook het kleine beetje sleutelen aan de code geeft geen soelaas.

De fout komt altijd terug in het onderstaand deel van de code (soms in de eerste regel, soms in de laatste)

        myString = Left(myString, Len(myString) - 1)
        myArray = Split(myString, "*")
        .Sheets(myArray).Copy

Enig verschil met het voorbeeldbestand is dat er meer tabbladen zijn (namelijk 12 totaal).
Alle Checkboxen beginnen wel met "CB_".

Mijn vermoeden wijst maar de "Mid" en de "Left" verwijzing, ik heb de getalen 3 en 4 aangepast naar bijvoorbeeld 5 en 6, of 6 en 6 maar helaas.

Grt,
Peter

 

[MDN111]

Beste Excellerend,

Ja, die gewijzigde code is natuurlijk gebaseerd op jouw voorbeeldbestand.

Wat je schrijft is niet echt duidelijk. Wat bedoel je met "mijn daadwerkelijke sheet"? Is dat een worksheet of een ander Excelbestand? Je schrijft: "Enig verschil met het voorbeeldbestand is dat er meer tabbladen zijn (namelijk 12 totaal)." Wat bedoel je daar mee? Dat er gewoon meer sheets zijn, of dat er ook meer sheets in de bijlage moeten komen?

Wat ik je wel kan melden is dat ik gebruik heb gemaakt van het feit de je in je voorbeeld de sheet-namen in de checkbox-namen verwerkt hebt (bijvoorbeeld "CB_Maandag" en "Maandag"). Misschien heeft dat er iets mee te maken?

Om het op te lossen is er toch wat meer informatie nodig. Is het mogelijk een "daadwerkelijk" voorbeeld met dummy gegevens bij te voegen?

Grtz,
MDN111.

 

[Excellerend]

Beste MDN111,

Sorry voor de verwarring, ik heb snel een vereenvoudigd bestand gemaakt waarin het doel van mijn vraag duidelijk naar voren moest komen.

De oplossing ga ik uiteindelijk toepassen in een ander Excelbestand. In dat Excelbestand staan meer dan 7 tabbladen, namelijk 12. Die tabbladen moet ook aangevinkt kunnen worden op het UserForm, en uiteindelijk gemaild kunnen worden.

Ik heb net alle sheet-namen aangepast naar de namen van de checkboxen, nu werkt de code volledig, waarvoor mijn dank.

Vraag opgelost.

Grt,
Peter