Opmaak gaat verloren tijdens uitvoeren vba

[stefano]

In een poging een 'range' in een werkblad te mailen (en niet het volledige bestand) gaat de opmaak binnen die range verloren. Gezien ik weinig verstand heb van vba raak ik er niet uit hoe ik dit kan corrigeren/omzeilen. In bijlage het bestand. Gelieve je eigen mailadres in te geven in cel Q7 aub

Sub mailen_range()
    Dim source As Range
    Dim ColumnCount As Long
    Dim FirstColumn As Long
    Dim ColumnWidthArray() As Double
    Dim lIndex As Long
    Dim lCount As Long
    Dim dest As Workbook
    Dim i As Long
    Dim strdate As String
    Dim pad As String
    Dim bestandsnaam As String
    
    Application.ScreenUpdating = False
    Set source = Nothing
    On Error Resume Next
    
'hieronder de range die in het nieuwe blad moet komen, graag met de originele opmaak


    Range("A1:w35").Select
    
    Set source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If source Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protect, please correct and try again.", vbOKOnly
        Application.ScreenUpdating = True
        Exit Sub
    End If

    ColumnCount = Selection.Columns.Count
    FirstColumn = Selection.Cells(1).Column - 1
    ReDim ColumnWidthArray(1 To ColumnCount)
    lIndex = 0
    For lCount = 1 To ColumnCount
        If Columns(FirstColumn + lCount).Hidden = False Then
            lIndex = lIndex + 1
            ColumnWidthArray(lIndex) = Columns(FirstColumn + lCount).ColumnWidth
        End If
    Next lCount
    Set dest = Workbooks.Add(xlWBATWorksheet)
    source.Copy
    With dest.Sheets(1)
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        For i = 1 To lIndex
            .Columns(i).ColumnWidth = ColumnWidthArray(i)
        Next
    End With
    With dest
        .SaveAs "Stefano" & ".xlsx"
        .SendMail Range("Q7"), "Stefano's Pizza - bloem Stefano - " & Format$(Range("b32"))
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close False
    End With
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

[ATTACH]291835.vB[/ATTACH]

 

[gast0660]

Dit zal niet lukken met al uw samengevoegde cellen.

 

[HSV]

Waarom niet een blad kopiëren?

Sub mailen_range()
 Sheets("certifikaat").Copy
     With ActiveWorkbook
        .SaveAs "C:\Temp\Stefano" & ".xlsx"
        .SendMail Range("Q7"), "Stefano's Pizza - bloem Stefano - " & Format$(Range("b32"))
        .Close 0
       Kill "C:\Temp\Stefano" & ".xlsx"
    End With
End Sub

 

[stefano]

Lijkt me pak logischer.

Reden voor de range was het feit dat onder rij 34 nog formules stonden die ik niet wou prijsgeven

ik heb die nu naar een ander tabblad verplaatst.

dank !

 

[stefano]

Nog een klein vraagje.

Ik wil in plaats van de c:\temp\ een padnaam ophalen uit cel aa1. Kan dit ? het lijkt niet te werken met onderstaande code.

Sub mailen_range()
 Sheets("certifikaat").Copy

[COLOR="#FF0000"]dim pad as string
pad = range("AA1")[/COLOR]
     With ActiveWorkbook
        .SaveAs [COLOR="#FF0000"][/COLOR][COLOR="#FF0000"]pad & [/COLOR]"Stefano" & ".xlsx"
        .SendMail Range("Q7"), "Stefano's Pizza - bloem Stefano - " & Format$(Range("b32"))
        .Close 0
       Kill "C:\Temp\Stefano" & ".xlsx"
    End With
End Sub

 

[HSV]

Wat staat er in AA1 ?

 

[stefano]

AA1 = c:\temp\

 

[HSV]

Zou gewoon moeten werken als je een map Temp hebt op de C-schijf.
Anders...
.SaveAs Range("AA1") & "Stefano" & ".xlsx"