2 of meerdere tabbladen versturen via e-mail.

[danny147]

Beste helpers,

Bedankt voor de reacties die ik thuis heb gekregen van o.a. Warme bakkertje, cow18 en Trucker10.

Ik heb gekozen voor de code van Warme bakkertje omdat deze meer variabel is.

De code van Cow18 was ook in orde met hier en daar wat meldingen als het fout ging.

Trucker10 voor de tips en assistentie.

Zie hier de code :

Sub Mail_Sheets()
'Working in 97-2010
    Dim FileExtStr As String, FileFormatNum As Long
    Dim Sourcewb As Workbook, Destwb As Workbook
    Dim TempFilePath As String, TempFileName As String
    Dim sh As Worksheet, I As Long, strto As String
    Dim TheActiveWindow As Window, TempWindow As Window
    Dim shtArray(), X As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    Set Sourcewb = ActiveWorkbook
    On Error Resume Next
    'For Each cell In ThisWorkbook.Sheets("Blad1") _
        .Range("A1:A10").Cells.SpecialCells(xlCellTypeConstants)
    For Each cell In ThisWorkbook.Sheets("E-mailadressen") _
        .Range("A1:A10").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    On Error GoTo 0
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
    sq = Sheets("E-mailadressen").Range("C2:C" & Sheets("E-mailadressen").Range("C20").End(xlUp).Row)
    For X = 1 To UBound(sq)
        Sheets(sq(X, 1)).Copy Before:=Sheets(1)
        With ActiveSheet
            .Unprotect
            .Cells.Copy
            .Cells.PasteSpecial Paste:=xlPasteValues
            .Protect
        End With
    Next
    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 ws In .Worksheets
            If Right(ws.Name, 3) = "(2)" Then
                intA = intA + 1
                ReDim Preserve shtArray(intA)
                shtArray(intA) = ws.Name
            End If
        Next ws
    .Sheets(shtArray).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-2010, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                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 If
    End With
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Overzicht TOUR de FRANCE " & Format(Now, "dd-mmm-yy")
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = strto
            .CC = ""
            .BCC = ""
            .Subject = "Overzicht TOUR de FRANCE " & Format(Now, "yyyy")
            .Body = "Wijzig indien nodig deze boodschap"
            .Attachments.Add (TempFilePath & TempFileName & FileExtStr)
            '.Send
            .Display
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Sheets(shtArray).Delete
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

Groetjes Danny. :thumb:

 

[Warme bakkertje]

'For Each cell In ThisWorkbook.Sheets("Blad1") _
        .Range("A1:A10").Cells.SpecialCells(xlCellTypeConstants)

Deze mag je nog verwijderen alsook Blad1. Dit waren enkel mijn Testcases

:thumb: