所以我有动态数量的工作表，我想循环遍历所有工作表，然后将所有工作表中的数据合并到一封电子邮件中。条件是，如果工作表的单元格 A1 为空，它将复制该工作表中的所有内容。但如果工作表的单元格 A1 不为空，它将仅复制单元格 B2，在下面放置两行空白行，然后复制我的电子邮件工作表的单元格 E10 中的数据。
这是我的代码。这只执行最后一张表。
Sub EmailReport()
Application.ReferenceStyle = xlA1
Dim rawSh As Worksheet
Dim ainfoSh As Worksheet
Dim emSh As Worksheet
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range
Dim lastRow As Long
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim SigString As String
Dim Signature As String
Dim SignatureRTA As String
Set rawSh = Worksheets("Raw Data")
Set ainfoSh = Worksheets("Info")
Set emSh = Worksheets("Email")
' By Ron de Bruin.
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.BodyFormat = 2
.To = emSh.Range("C6").Value
.CC = emSh.Range("C7").Value
.BCC = ""
.Subject = emSh.Range("C5").Value
'loop through all worksheets
For Each wks In ActiveWorkbook.Worksheets()
Set rng = Nothing
SheetName = wks.Name
On Error Resume Next
'check if the name of the sheet is included in the funds list
Set rng = ainfoSh.Range("I:I").Find(SheetName, LookAt:=xlWhole)
On Error GoTo 0
If rng Is Nothing Then GoTo NextWorksheet 'NOT included in list
Application.DisplayAlerts = False 'Surpress warning message
'my code here
lastRow = wks.Range("B:C").Cells(Rows.Count, 1).End(xlUp).Row
LastRow1 = wks.Range("E:Q").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = wks.Range("S:AA").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Nothing
' Only send the visible cells in the selection.
x = wks.UsedRange.Rows.Count
Set rng = wks.Range("B2:C" & lastRow).SpecialCells(xlCellTypeVisible)
Set rng1 = wks.Range("E4:Q" & LastRow1).SpecialCells(xlCellTypeVisible)
Set rng2 = wks.Range("S4:AA" & LastRow2).SpecialCells(xlCellTypeVisible)
Set rng3 = wks.Range("B2").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>THIS IS WHERE THE TROUBLE IS
If wks.Range("A1").Value = "" Then
.HTMLBody = "<table align = left>" & emSh.Range("C8") & "<Br>" & RangetoHTML(rng) & "<Br>" & RangetoHTML1(rng1) & "<Br>" & RangetoHTML1(rng2)
Else
.HTMLBody = "<table align = left>" & emSh.Range("C8") & "<Br>" & RangetoHTML3(rng3) & "<Br>" & "<Br>" & emSh.Range("E10")
End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
NextWorksheet:
Next wks
Set ainfoSh = Nothing
.Importance = 2
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Set rng = Nothing
End Sub
'>>>>>>>>>>>>>>> 中包含的代码是我遇到问题的部分。请帮忙。我非常感谢所有能得到的帮助。谢谢
答案1
似乎每次迭代之后，你都会替换 的值.HTMLBody。你没有保留先前的值。
尝试：
If wks.Range("A1").Value = "" Then
.HTMLBody = .HTMLBody & "<table align = left>" & emSh.Range("C8") & "<Br>" & RangetoHTML(rng) & "<Br>" & RangetoHTML1(rng1) & "<Br>" & RangetoHTML1(rng2)
Else
.HTMLBody = .HTMLBody & "<table align = left>" & emSh.Range("C8") & "<Br>" & RangetoHTML3(rng3) & "<Br>" & "<Br>" & emSh.Range("E10")
End If