Excel 根据单元格值调用两个宏的宏

我有一段代码：

根据单元格值调用其他两个宏的宏如下：

    Option Explicit

    Function lastRow(col As Variant, Optional wks As Worksheet) As Long

        If wks Is Nothing Then
            Set wks = ActiveSheet
        End If

        lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row

    End Function

Sub runMacros()
    Dim vDat As Variant
    Dim i As Long

    Dim wks As Worksheet
    Set wks = ActiveSheet

    With wks
        vDat = .Range(.Cells(1, "G"), .Cells(lastRow("G"), "G"))
    End With

    For i = LBound(vDat) To UBound(vDat)
        If vDat(i, 1) = "First" Then
            Macro3
            Macro1
        ElseIf vDat(i, 1) = "Second" Then
            Macro3
            Macro2
        End If
    Next i

End Sub

调用的第一个宏是this（Macro3）-如果不存在，它只会创建一个新文件夹：

Sub Macro3()
Dim Path As String
Dim Folder As String
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)

If Folder = vbNullString Then
    MkDir "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
End If
End Sub

然后我有一个宏：

    Sub Macro1()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, SavePath As String, StrFileName As String, MailSubjectName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document

wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
SavePath = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" 'Name of the folder
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "RejectionLetterEmployee.docx" 'Name of the word file
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
  With .MailMerge
    .MainDocumentType = wdFormLetters
    .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
      LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
      "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
      SQLStatement:="SELECT * FROM `Rejection$`"
   For i = 1 To .DataSource.RecordCount
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        If Trim(.DataFields("Name")) = "" Then Exit For
        StrName = .DataFields("Name") 'File name will be determined by this column name
        MailSubjectName = .DataFields("ID")
      End With
      .Execute Pause:=False
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
        MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
      Next
      StrName = Trim(StrName)
      StrFileName = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" & StrName
      With wdApp.ActiveDocument
        '.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False 'Save as WORD file(not needed at the moment)
        ' and/or:
        '.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder where the excel sheet exists(not needed)
        .SaveAs Filename:=SavePath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder that has been created by Path_Exists function
        .Close SaveChanges:=False
  ' Set OutApp = CreateObject("Outlook.Application")
  ' Set OutMail = OutApp.CreateItem(0)
  '  On Error Resume Next
  '  With OutMail
     '   .To = ""
     '   .SentOnBehalfOfName = ""
     '   .CC = ""
     '   .BCC = ""
     '   .Subject = "ID" & " " & MailSubjectName & " " & StrName
     '   .BoDy = ""
      '  .Attachments.Add StrFileName & ".pdf"
    '    .Display
        '.Send
  '  End With
 '   On Error GoTo 0
 '  Set OutMail = Nothing
'   Set OutApp = Nothing
      End With
  '  Next i
    .MainDocumentType = wdNotAMergeDocument
  End With
  .Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub

Macro1和Macro2是相同的代码，但它们使用不同的Word文件来创建PDF-如果“G”列中的单元格包含字符串“first”，则Macro1运行，如果包含“second”，则Macro2运行。 宏将创建一个PDF文件并通过Outlook发送

Macro1和Macro2的问题是它们有一个For循环，它贯穿所有行，这基本上与我基于单元格值想要做的事情相矛盾。 我试着对它进行了一些调整，但由于我对VBA不太熟悉，因此我无法根据调用其他两个宏时执行的For循环使它在行上运行。 我只成功地使它只在第一行或最后一行工作

所以我的问题是：如何修复Macro1代码以处理运行macros（）check的行

例如：runMacros（）通过按钮执行。 它检查G2单元格是否包含“第一个”或“第二个”

如果包含“第一个”，则将运行Macro3和Macro1。
如果它包含“秒”，它将运行Macro3和Macro2

然后，runMacros（）将转到下一行，检查并执行宏，直到到达空行

目前Macro1和Macro2有一个for循环，这是错误的，因为如果G2包含“first”，G3包含“second”，则所有PDF文件都将符合Macro2的要求，因为它只是取代了Macro1的功能

我希望Macro1和Macro2跟随runMacros（）正在检查的行，并且只在该行上执行

---

我如何做到这一点？

在回答您传递参数的问题时，有几种方法可以做到这一点。在第一个示例中，将

vDat

变量创建为

范围

，然后循环该范围并传递范围参数

Sub runMacros()
    Dim wks As Worksheet
    Set wks = ActiveSheet

    Dim vDat As Range
    With wks
        Set vDat = .Range("G1").Resize(lastRow("G"), 1)
    End With

    Dim i As Long
    For i = 1 To vDat.Rows.Count
        If vDat.Offset(i, 0).Value = "First" Then
            Macro3 vDat.Rows(i)
            Macro1 vDat.Rows(i)
        ElseIf vDat.Offset(i, 0).Value = "Second" Then
            Macro3 vDat.Rows(i)
            Macro2 vDat.Rows(i)
        End If
    Next i
End Sub

Private Sub Macro1(ByRef theRow As Range)
    Debug.Print "Macro1 row address = " & theRow.Address
End Sub

Private Sub Macro2(ByRef theRow As Range)
    Debug.Print "Macro2 row address = " & theRow.Address
End Sub

Private Sub Macro3(ByRef theRow As Range)
    Debug.Print "Macro3 row address = " & theRow.Address
End Sub

但是实际上您创建了

vDat

作为数组，因此您可以在数组中传递该行的值：

Sub runMacros()
    Dim wks As Worksheet
    Set wks = ActiveSheet

    Dim vDat As Variant
    With wks
        vDat = .Range("G1").Resize(lastRow("G"), 1).Value
    End With

    Dim i As Long
    For i = LBound(vDat, 1) To UBound(vDat, 1)
        If vDat(i, 0) = "First" Then
            Macro3 vDat(i, 0)
            Macro1 vDat(i, 0)
        ElseIf vDat(i, 0) = "Second" Then
            Macro3 vDat(i, 0)
            Macro2 vDat(i, 0)
        End If
    Next i
End Sub

Private Sub Macro1(ByVal theRowValue As Variant)
    Debug.Print "Macro1 row value = " & theRowValue
End Sub

Private Sub Macro2(ByVal theRowValue As Variant)
    Debug.Print "Macro2 row value = " & theRowValue
End Sub

Private Sub Macro3(ByVal theRowValue As Variant)
    Debug.Print "Macro3 row value = " & theRowValue
End Sub

---

代码和问题中不清楚的是，行与

数据源的关系如何，或者在
Macro1
或
Macro2
中如何使用它。我还建议将宏重命名为更能描述宏执行的操作。
使用MailMerge，您可以从数据源创建一批文档。
使用Status列作为数据源SQL中的WHERE子句，可以创建
只有两次运行同一子例程的文档使用一个参数应用不同的模板


选项显式
子运行宏（）
Dim Template1为字符串，Template2为字符串，路径为字符串，文件夹为字符串
Template1=此工作簿.Path&“RejectionLetterEmployee.docx”
Template2=ThisWorkbook.Path&“RejectionLetterEnterpriser.docx”
'为文档创建路径
Path=“C:\Users\”环境（“用户名”）和“\Desktop\Rejection文件夹”
Folder=Dir（路径，vbDirectory）
如果Folder=vbNullString，则
MkDir路径
如果结束
'创建文档
CreateDocuments“第一”，模板1，路径
CreateDocuments“第二个”，模板2，路径
MsgBox“结束”
端接头
子CreateDocuments（状态为字符串、模板为字符串、保存路径）
MsgBox“使用”&Template&vbCrLf&_
“进入文件夹”&保存路径，VBA信息
Const StrNoChr As String=“”*。/\：？|”
'路径和文件名
Dim strMMSrc作为字符串，strMMDoc作为字符串，strMMPath作为字符串
Dim StrFileName作为字符串，t0作为单个
t0=计时器
'打开模板
Dim wdApp作为新单词。应用程序，wdDoc作为单词。文档，i作为整数，j作为整数
Dim strName、MailSubjectName
wdApp.Visible=False
wdApp.displayerts=wdAlertsNone
设置wdDoc=wdApp.Documents.Open（_
文件名：=模板_
AddToRecentFiles:=False_
只读：=真_
可见：=假）
strMMSrc=thishworkbook.FullName'数据源名称
使用wdDoc.MailMerge
.MainDocumentType=wdFormLetters
.Destination=wdSendToNewDocument
.suppress blanklines=True
.OpenDataSource名称：=strMMSrc，只读：=True，AddStoreCentFiles:=False_
LinkToSource:=False，连接：=“Provider=Microsoft.ACE.OLEDB.12.0；User ID=Admin；”_
“数据源=strMMSrc；模式=Read；扩展属性=”“HDR=YES；IMEX=1”“；”_
SQLStatement:=“从`拒绝$`中选择*，其中状态='”&状态&“
'确认创建文档
如果vbNo=MsgBox（.DataSource.RecordCount&“文档将在”&SavePath&_
“是否继续？”，vbYesNo，“确认”），然后
跳绳
如果结束
'为数据源中的每条记录创建一个文档
对于i=1到.DataSource.RecordCount
使用.DataSource
.FirstRecord=i
.LastRecord=i
.ActiveRecord=i
strName=Trim（.DataFields（“Name”））
MailSubjectName=Trim（.DataFields（“ID”））
'Debug.Print“Raw”、i、strName、MailSubjectName
如果strName=“”，则退出
以
“合并吗
.执行暂停：=False
'构造要保存的文档文件名
'替换非法字符
对于j=1至Len（标准偏差）
strName=替换（strName，Mid（StrNoChr，j，1），“”）
MailSubjectName=替换（MailSubjectName，Mid（StrNoChr，j，1），“”）
下一个
调试。打印“已清理”、i、strName、MailSubjectName
'保存到已由Path_Exists函数创建的文件夹
StrFileName=SavePath&strName
使用wdApp.ActiveDocument
.SaveAs文件名：=SavePat