Mail ny fil med 2 ark fra samme gl. fil
HejJeg har tidligere benyttet mig af Ron de Bruins hjemmeside når jeg har haft brug for nogle e mail markroer.
Jeg har nu den udfordring at jeg skal lave noget vba der kan sende 2 ark - fra samme fil udfra kriterier fra det ene ark.
Det ene ark er dynamisk - dvs. hvis arket har en mailadr. i celle a1 så skal det sendes. I samme fil har jeg et andet ark (Kunder)(fast)som jeg gerne vil have med hver gang der mailes.
Mit udgangspunkt er nedenstående VBA kode fra Ron de bruin der dog kun medtage det ark hvor der er angivet en mailadr.
Sub Mail_Every_Worksheet()
'Working in 2000-2010
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
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")
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 = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
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
Håber at hører fra jer.