Question

你好我在一个模块中有这两个宏，但是当我运行它时只运行删除行的第一部分，但我希望它也能发送电子邮件......我从@Simoco那里得到了一些很好的帮助早些时候发送部分，但似乎无法弄清楚组合部分...

我试图添加Call Sub ...但没有运气

很抱歉代码的长度......

Sub DeleteDuplicateRows()

Dim R As Long
Dim N As Long
Dim V As Variant
Dim rng As Range

Range("D2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("D2").Select
    Selection.Copy
    Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Rows("1:3").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    Columns("A:A").EntireColumn.AutoFit

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(rng.Row, "#,##0")
N = 0
For R = rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = rng.Cells(R, 1).Value
If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(rng.Columns(1), vbNullString) > 1 Then
        rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
Else
    If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
        rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)

End Sub

Sub Send_Email()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Dim lastrow As Long
Set OutApp = CreateObject("Outlook.Application")


SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

lastrow = Cells(Rows.Count, 3).End(xlUp).Row

For Each cel In Range("C2:C" & lastrow)
strbody = "Hi there" & cel.Offset(, -1) & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
cel.Offset(, 3) & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"

On Error Resume Next
With OutApp.CreateItem(0)
If cel.Value <> "" Then
.To = cel.Value
.CC = cel.Offset(0, 10).Value
.Body = strbody & vbNewLine & vbNewLine & Signature
Else
.To = cel.Offset(0, 10).Value
.Body = "Hello " & cel.Offset(, 9) & "! " & cel.Offset(, -1) & "  is having this event" & vbNewLine & Signature
'.HTMLBody = strbody & vbNewLine & RangetoHTML(cel.Offset(, -2).Resize(, 4)) & vbNewLine & Signature
End If
'.BCC = ""
.Subject = "Choose your plan"
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel


Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Answer 1

如果执行宏，则调用一个过程或一个函数。我假设您要致电Delete_Duplicate_Rows和Send_Email。要执行两个过程，您可以创建一个调用其他过程的过程

Sub Delete_And_Send()
    Call Delete_Duplicate_Rows()
    Call Send_Email()
End Sub

2宏1模块

1 个答案: