0
このサイトを検索した後、私が必要としているものとほとんど同じマクロを見つけました。マクロはとてもうまく動作しますが、いくつか微調整したいのですが、私はVBAに熟練していません。ワークシート内の各人にパーソナライズされた電子メールを送信
ここでマクロにリンクされている：
http://www.rondebruin.nl/win/s1/outlook/bmail8.htm
ここではコードである：ここ
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = Cws.Cells(Rnum, 1).Value
.Subject = "Test mail"
.HTMLBody = RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
はまた、マクロに含まれる関数である：
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add(_
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
私の目標は、ワークシートのすべての電子メールアドレスに電子メールを送信し、秒をCCingすることですデータの行に含まれる電子メールアドレスと、電子メールの本文の行のデータが含まれます。
だから私のExcelワークシート内のデータは、この（列AG）のようになります。
[email protected] - [email protected] - data1 - data2 - data3 - data4 - data5
列Aメインの電子メールで、列BがメールをCc送信される電子メールで、列CGがなります電子メールの本文に含まれるデータ。
私は現在、上記のリンクの例2のコードを使用しています。このコードは、すべての固有の電子メールアドレスに対して自分のデータを自動フィルタリングするので、同じアドレスに複数の電子メールを送信するわけではありません。 1つの問題は、マクロが電子メールの本文にデータ行全体（列A〜G）を含むことです。私は列C-Gのみを表示したいと思います。
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
ここで.Offsetを追加すると、マクロはC-G列のデータのみを取り込むことができますか？
もう1つの問題は、データの各行に含まれる2番目の電子メールアドレスを参照する方法がマクロに含まれていないことです。誰かがこれを達成するのを手助けできますか？
また、一度にすべてを送信するのではなく、一度に1つのメールを準備することも可能ですか？私のワークシートには約300のユニークな電子メールアドレスがあり、それらを確認してから手動で1つずつ送信したいと思います。送信をクリックするとすぐにメールを準備して次のメールに進む方法はありますか？
ありがとうございました！
差し込み印刷にCCのオプションがありません – emd023
OutMail.Body = RangetoHTML（）行でエラーが発生しました。 – emd023
私はミスマッチエラーがあります：lastrow = range（ "A"＆Rows.Count）.End（x1Up） – emd023