Send udvalg af Rækker fra Excel til Email adresser

Det kan klares med brevfletning, men du får en mail pr. række i Excel-arket.
Ellers må du omstrukturere dine data.

Hej Erik

Det var netop den mur jeg rendte ind i.
Hvis jeg brugte brevfletningen, ville jeg skulle give spam-kage de næste 30 år ;)

Jeg ville gerne undgå at lave det manuelt.

Og håber at nogen her måske ved hvordan man koder sig ud af sådan en omgang :)

Det skulle nok være muligt.

Hvordan skal rækkerne sendes - som vedhæftet fil eller som rækker i selve teksten?

Har du adgang til Outlook?

Hej Supertekst

Helst som vedhæftet fil, men hvis det bliver som rækker i teksten ville det også være OK

Ja, jeg har adgang til outlook

Ok - vender tilbage..

VBA-koden anbringes under Ark1 / Højre klik / Vis programkode
Hvis du vil have min model - så send en mail. @-adresse uner min profil.


Dim sti As String
Dim antalRækker As Integer, antalKolonner As Integer, ræk As Integer, mailadresse As String
Dim startRæk As Integer, slutRæk As Integer
Dim attFilnr As Integer

Dim systemXLS As Workbook, område As Range, Ws As Worksheet
Dim attXLS As Workbook
Public Sub fordelingAfMails()
    Application.DisplayAlerts = False
   
    sti = ActiveWorkbook.Path & "\"
    Set systemXLS = ActiveWorkbook
    attFilnr = 1
   
    Set Ws = ActiveWorkbook.Sheets(1)
Rem beregn antal rækker
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    antalKolonner = ActiveCell.SpecialCells(xlLastCell).Column
   
Rem sortering iflg. emailadresse
    sortering antalRækker
   
Rem hent første mailadresse
    mailadresse = systemXLS.Sheets(1).Range("C2")
    startRæk = 2
    For ræk = 3 To antalRækker
        If Range("C" & ræk) <> mailadresse Then
            slutRæk = ræk - 1
            klargørTilSendMail startRæk, slutRæk, attFilnr
           
            sendMailen mailadresse, sti, "AttData_" & attFilnr & ".xlsx"
            attFilnr = attFilnr + 1
            startRæk = ræk
            mailadresse = Range("C" & ræk)
        End If
    Next ræk

    klargørTilSendMail startRæk, ræk - 1, attFilnr
   
    sendMailen mailadresse, sti, "AttData_" & attFilnr & ".xlsx"
End Sub
Private Sub klargørTilSendMail(fraRæk, tilRæk, attFilnr)
    ActiveWorkbook.ActiveSheet.Range("A" & fraRæk & ":D" & tilRæk).Select
    Selection.Copy
   
    Workbooks.Open sti & "AttData.xlsx"
    ActiveWorkbook.Sheets(1).Range("A2").Select
    ActiveSheet.Paste
   
    ActiveWorkbook.SaveAs sti & "AttData_" & attFilnr & ".xlsx"
    ActiveWorkbook.Close
End Sub
Private Sub sendMailen(mailadresse, sti, filnavn)
Dim mailApp, Namespace
    Set mailApp = CreateObject("Outlook.application")
    Set Namespace = mailApp.GetNamespace("MAPI")
   
    Set nymail = mailApp.CreateItem(olMailItem)
    Set TilModtager = nymail.Recipients.Add(mailadresse)
   
    nymail.Subject = "Data"                    'Emne
    nymail.Attachments.Add sti & filnavn
    nymail.Display                              'Viser mailen som da kan ajourføres.
'    nyMail.Send            'Ej automatisk under test - fjern ' yderst til venstre
End Sub
Private Sub sortering(antalRækker)
    Range("C1").Select
    ActiveWorkbook.Worksheets("Ark1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Ark1").Sort.SortFields.Add Key:=Range("C2:C" & antalRækker), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Ark1").Sort
        .SetRange Range("A1:D" & antalRækker)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

PS: Anvend Kommentar og ikke Svar. Svar anvendes kun af forslagsstiller.

Tak for hjælpen Supertekst
Du er en ægte helt :)

Selv tak