Makro til E-mail af udvalgte excel ark

Her er et bud:

Option Explicit

Sub Printtotal()
    Dim i As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet
    Dim OriginalSheet As Worksheet
    Dim cb As CheckBox
    Application.ScreenUpdating = False

'  Check for protected workbook
    If ActiveWorkbook.ProtectStructure Then
        MsgBox "Projektmappen er beskyttet!", vbCritical
        Exit Sub
    End If

'  Add a temporary dialog sheet
    Set OriginalSheet = ActiveSheet
    Set PrintDlg = ActiveWorkbook.DialogSheets.Add

    SheetCount = 0

'  Add the checkboxes
    TopPos = 40
    For i = 1 To ActiveWorkbook.Worksheets.Count
        Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'      Skip empty sheets and hidden sheets
        If Application.CountA(CurrentSheet.Cells) <> 0 And _
            CurrentSheet.Visible Then
            SheetCount = SheetCount + 1
            PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
                PrintDlg.CheckBoxes(SheetCount).Text = _
                    CurrentSheet.Name
            TopPos = TopPos + 13
        End If
    Next i

'  Move the OK and Cancel buttons
    PrintDlg.Buttons.Left = 240

'  Set dialog height, width, and caption
    With PrintDlg.DialogFrame
        .Height = Application.Max _
            (68, PrintDlg.DialogFrame.Top + TopPos - 34)
        .Width = 230
        .Caption = "Vælg hvilke ark der skal udskrives"
    End With

'  Change tab order of OK and Cancel buttons
'  so the 1st option button will have the focus
    PrintDlg.Buttons("Button 2").BringToFront
    PrintDlg.Buttons("Button 3").BringToFront

'  Display the dialog box
    OriginalSheet.Activate
    Application.ScreenUpdating = True
    If SheetCount <> 0 Then
        If PrintDlg.Show Then
            For Each cb In PrintDlg.CheckBoxes
                If cb.Value = xlOn Then
                    Worksheets(cb.Caption).Select Replace:=False
                    SendPost Worksheets(cb.Caption)
                End If
            Next cb
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
'          ActiveSheet.Select
        End If

    Else
        MsgBox "Alle ark er tomme!"
    End If

'  Delete temporary dialog sheet (without a warning)
    Application.DisplayAlerts = False
    PrintDlg.Delete

'  Reactivate original sheet
    OriginalSheet.Activate
End Sub
Sub SendPost(ark)
Dim modtager As String
'If Application.MailSystem <> xlNoMailSystem Then
    modtager = ActiveSheet.Range("F11")
 
'  Sheets("ark").Copy ' ret navnet(DitArk") til navnet på det ark der skal sendes
  With ActiveWorkbook
        .SendMail _
        Recipients:=modtager, _
        Subject:="Overslag fra Transsoft"
        .Close SaveChanges:=False
  End With
'End If
End Sub

Den virker desværre ikke. Der bliver godt nok lavet en mail med en vedhæftet fil. desværre indeholder den vedhæftede fil alle ark fra regnearket og ikke kun de markedrede. Herudover er der et nyt ark i projektet, der viser dialogboksen og de valg jeg foretog.

Anyway, du er nok inde på noget af det rigtige... flere forslag er velkomne :-)

/E100

OK - blev udarbejdet lidt hurtigt - vil se på, når der bliver lidt luft.

Prøv at se på denne udgave:

'Option Explicit,
Dim wb As Workbook, xBook As Workbook, wbArk
Sub Printtotal()
    Dim i As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet
    Dim OriginalSheet As Worksheet
    Dim cb As CheckBox
    Application.ScreenUpdating = False

'  Check for protected workbook
    If ActiveWorkbook.ProtectStructure Then
        MsgBox "Projektmappen er beskyttet!", vbCritical
        Exit Sub
    End If

'  Sæt object for aktuelle fil
    Set xBook = ActiveWorkbook
    wbArk = 0

'  Add a temporary dialog sheet
    Set OriginalSheet = ActiveSheet
    Set PrintDlg = ActiveWorkbook.DialogSheets.Add

    SheetCount = 0

'  Add the checkboxes
    TopPos = 40
    For i = 1 To ActiveWorkbook.Worksheets.Count
        Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'      Skip empty sheets and hidden sheets
        If Application.CountA(CurrentSheet.Cells) <> 0 And _
            CurrentSheet.Visible Then
            SheetCount = SheetCount + 1
            PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
                PrintDlg.CheckBoxes(SheetCount).Text = _
                    CurrentSheet.Name
            TopPos = TopPos + 13
        End If
    Next i

'  Move the OK and Cancel buttons
    PrintDlg.Buttons.Left = 240

'  Set dialog height, width, and caption
    With PrintDlg.DialogFrame
        .Height = Application.Max _
            (68, PrintDlg.DialogFrame.Top + TopPos - 34)
        .Width = 230
        .Caption = "Vælg hvilke ark der skal udskrives"
    End With

'  Change tab order of OK and Cancel buttons
'  so the 1st option button will have the focus
    PrintDlg.Buttons("Button 2").BringToFront
    PrintDlg.Buttons("Button 3").BringToFront

'  Display the dialog box

    OriginalSheet.Activate
   
    Application.ScreenUpdating = True
    If SheetCount <> 0 Then
        If PrintDlg.Show Then
            For Each cb In PrintDlg.CheckBoxes
                If cb.Value = xlOn Then
                    kopierArk cb.Caption, wbArk
                End If
            Next cb
'            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
'          ActiveSheet.Select
        End If

    Else
        MsgBox "Alle ark er tomme!"
    End If

'  Delete temporary dialog sheet (without a warning)
    Application.DisplayAlerts = False
    PrintDlg.Delete

'  Reactivate original sheet
    OriginalSheet.Activate
   
    SendPost ActiveSheet.Range("F11")
    ActiveSheet.Cells(1, 1).Select
   
End Sub
Sub SendPost(modtager)
'If Application.MailSystem <> xlNoMailSystem Then
 
  wb.Activate
  With ActiveWorkbook
        .SendMail _
        Recipients:=modtager, _
        Subject:="Overslag fra Transsoft"
        .Close savechanges:=False
  End With
'End If
End Sub
Sub kopierArk(arkNavn, arknr)
    If arknr = 0 Then
        opretNyWb
    End If
   
    arknr = arknr + 1
    kopier arkNavn, arknr
End Sub
Sub opretNyWb()
    Workbooks.Add
    Set wb = ActiveWorkbook
    Application.DisplayAlerts = False
   
    For f = wb.Worksheets.Count To 2 Step -1
        wb.Worksheets(f).Delete
    Next f
End Sub
Sub kopier(arkNavn, arknr)                      'OK
    xBook.Activate
   
    Sheets(arkNavn).Select
    ActiveSheet.Cells.Select
    Selection.Copy
    wb.Activate
   
    If wb.Worksheets.Count < arknr Then
        wb.Worksheets.Add after:=Worksheets(arknr - 1)
    End If
   
    With ActiveWorkbook.Sheets(arknr)
        .Cells(1, 1).Select
        .Paste
        .Cells(1, 1).Select
        .Name = arkNavn
    End With
   
    xBook.Activate
    Application.CutCopyMode = False
End Sub