excelvba中的IF和语句
我正在尝试自动化Outlook电子邮件,并具有当前代码,但我需要它还具有以下条件:列AF小于或等于7: 电子邮件地址在H列,天数在AF列 -这目前可以正常工作,但会创建所有电子邮件,而不是出于某种原因过滤AFexcelvba中的IF和语句,excel,vba,if-statement,outlook,automation,Excel,Vba,If Statement,Outlook,Automation,我正在尝试自动化Outlook电子邮件,并具有当前代码,但我需要它还具有以下条件:列AF小于或等于7: 电子邮件地址在H列,天数在AF列 -这目前可以正常工作,但会创建所有电子邮件,而不是出于某种原因过滤AF Sub Send_Second_CDQR_Notification() Dim OutApp As Object Dim OutMail As Object Dim rng As Range Dim Ash As Worksheet Dim Cws As Worksheet Dim Rco
Sub Send_Second_CDQR_Notification()
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
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
' DECLARE VARIABLES
Dim LR, eError, AppName, fName, lName, FromMail, CCMail, dDate
'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:AF" & Ash.Rows.Count)
FieldNum = 8 'Filter column = H 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
'If the unique value is a mail address create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" And_
Cws.Cells(Rnum, 32) <= 7 Then
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Your data of " & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
fName = Range("D" & 2).Value
lName = Range("E" & 2).Value
AppName = Range("C" & 2).Value
eError = Range("A" & 2).Value
dDate = Format(Now(), "d mmmm yyyy")
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Cc = "email"
.SentOnBehalfOfName = FromMail
.Subject = "2nd Notification"
.Attachments.Add NewWB.FullName
.Display 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
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
我不确定这是否与我调用专栏的方式或它的编写方式有关。我还认为带有电子邮件H的行将始终有一个电子邮件地址,它永远不会是空的,因此if语句甚至可能只关于if AF,正如Dave指出的,您的查询令人困惑。您声明您正在测试AF,但您正在查看第25列。查看代码的其余部分,您的表原点是A1,因此您希望测试AF的第32列 下面将测试A列是否符合您的原始测试电子邮件地址,以及AF列是否包含小于或等于7的数字
If cws.Cells(rnum, 1).Value Like "?*@?*.?*" And _
Val(cws.Cells(rnum, 32) <= 7 Then
只是想澄清一下?列25将是列Y而不是列AF,除非您有指示从列开始的筛选的内容H@Davesexcel我编辑以包含整个代码这仍然不起作用,我有一个有4行的样本表,只有1行有其他3个AF单元格中的值?对于测试,我有7,15,6和12-所以它应该只创建2个emailsOkay,在这里我能想到的唯一一件事,除了奇怪的格式之外,就是值是文本。我会调整我的答案。
'If the unique value is a mail address create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" And _
Cws.Cells(Rnum, "AF") <= "7" Then
If cws.Cells(rnum, 1).Value Like "?*@?*.?*" And _
Val(cws.Cells(rnum, 32) <= 7 Then
If cws.Cells(rnum, 1).Value Like "?*@?*.?*" And _
Val(cws.Cells(rnum, 32).value) <= 7 and cws.Cells(rnum, 32)<>"" Then
Debug.Print "Value in " & cws.Cells(rnum, 32).Address & " is: [" & cws.Cells(rnum, 32) & "]"