VBA code aanpassen voor het verzenden van waarden

[peter59]

Hallo,

Ik ben behoorlijk aan het stoeien om een code van Ron de Bruin werkend te krijgen.
Het is de bedoeling dat de onderstaande code de desbetreffende tabbladen als waarden kopieert en per e-mail verstuurd.
De code werkt perfect maar aangezien ik nu in het bestand met draaitabellen werk verzend de code de hele sheet. Dat is niet de bedoeling.
Ik heb al van alles geprobeerd om het e.e.a. aan te passen maar loop stuk bij 'Change all cells in the worksheet to values if you want. Het origineel is helaas niet te reproduceren tot een voorbeeldje.
Ik hoop dat me toch iemand de goede weg kan op duwen.

Sub Mail_Every_Worksheet()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim cell As Range

    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2013
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
     '    'Change all cells in the worksheet to values if you want
   End
        Destwb.Sheets(1).UsedRange
          .Cells.Copy
          .Cells.PasteSpecial xlPasteValues
          .Cells(1).Select
       End With
       Application.CutCopyMode = False


    Set OutApp = CreateObject("Outlook.Application")

    For Each sh In ThisWorkbook.Worksheets
        If sh.Range("A1").Value Like "?*@?*.?*" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = "Planningsoverzicht tbv " & sh.Name & " van " _
                    & Format(Now, "dd-mm-yy")

            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                On Error Resume Next
                With OutMail
                    .to = sh.Range("A1").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "Planningsoverzicht"
                        For Each cell In ThisWorkbook.Sheets("Tekst Email").Range("A1:A60")
                        strbody = strbody & cell.Value & vbNewLine
                Next
                .Body = strbody

                    .Attachments.Add wb.FullName
                    'You can add other files also like this
                    '.Attachments.Add ("C:\test.txt")
                    .Display   '.Send voor daadwerkelijk te versturen of.Display voor een voorbeeld
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With
            
            Set OutMail = Nothing

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    Set OutApp = Nothing

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

 

[Cobbe]

Vervang dit eens:

'    'Change all cells in the worksheet to values if you want 
End
        Destwb.Sheets(1).UsedRange
          .Cells.Copy
          .Cells.PasteSpecial xlPasteValues
          .Cells(1).Select
       End With
       Application.CutCopyMode = False

'    'Change all cells in the worksheet to values if you want

         With Sheets(1).UsedRange
          .Cells.Copy
          .Cells.PasteSpecial xlPasteValues
          .Cells(1).Select
       End With
       Application.CutCopyMode = False

 

[peter59]

Hallo Cobbe

Vooraleerst dank voor het meedenken.
Maar helaas krijg ik onderstaande fout melding.



Mvg
Peter

 

[Cobbe]

Je hebt dat stuk code toch ook niet vervangen.

 

[peter59]

Cobbe,

Volkomen gelijk. Excuses hier voor.
Ik had alleen het woordje "End" verwijderd en niet verder gekeken.
Nu wel de code geheel gekopieerd en geplakt in het origineel.
Maar helaas.


Mvg
Peter

 

[Cobbe]

Bij mij loopt de code gewoon door.
Cells(1).select kan je gewoon weg laten is voor niets nodig.

Waarom de cursor nier naar cells(1) springt weet ik niet zonder het bestand te kennen.

 

[peter59]

Hallo Cobbe

Dank voor je geduld.
Ik heb de "Cells(1).select" verwijderd en dan krijg ik wat ik juist tracht te voorkomen. De ongefilterde waarden van de draaitabel wordt verzonden en niet de gefilterde waarden.

Mvg
Peter

 

[peter59]

Hallo,

Er is helaas niet veel respons meer gekomen. Misschien te onduidelijk gesteld?
Ik wil Cobbe toch bedanken voor het meedenken.

Ik heb het e.e.a. opgelost d.m.v. het opnemen van een macro voor het kopiëren en plakken als waarden in een nieuw tabblad.
Het is via een langere weg naar Rome maar het functioneert.

Mvg
Peter

 

[VenA]

Er komt weinig/geen respons omdat je er geen excel voorbeeldje bij gedaan hebt. Met plaatjes kan bijna niemand wat en om het geheel na te bootsen heeft over het algemeen niemand zin in.

Volens mij zou de code van Cobbe moeten werken. Dus de langere weg lijkt mij niet nodig.