A macro that calls 2 macros depending on the cell value

Question

I have this chunk of code :

The macro that calls 2 other macros depending on the cell value is this :

    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

The first macro that is being called is this(Macro3) - it just creates a new folder if it does not exist:

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

and then I have this macro:

    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 and Macro2 are the same code but they use a different Word file to create the PDF - Macro1 runs if a cell in "G" column contains the string "first" and Macro2 runs if it contains "second". The macros create a PDF file and sends it via Outlook.

The problem with Macro1 and Macro2 is that they have a For loop which runs through all rows which basically contradicts what I want to do based on a cell value. I tried to tweak it a little but since im not familiar that much with VBA I couldnt make it run on the row based on the For loop that runMacros() executes when it calls the 2 other macros. I only succeeded making it work only on the first row or the last row.

So my question is this : How would I fix Macro1 code to work on a row that runMacros() check.

For example : runMacros() is executed via button. it checks if G2 cell contains either "first" or "second".

if it contains "first" it will run Macro3 and Macro1.
if it contains "second" it will run Macro3 and Macro2.

runMacros() will then go to the next row, check and execute the macros until it reaches an empty row.

currently Macro1 and Macro2 have a for loop which is wrong because if the G2 contains "first" and G3 contains "second" all the PDF files will be according to Macro2 because it just replaced what Macro1 did

I want Macro1 and Macro2 to follow the row that runMacros() is checking and only execute on that row.

How do I do that?

Answer 1

With MailMerge you can create a batch of documents from a datasource. Using the Status column as a WHERE clause in the datasource SQL allows you to create the documents with only 2 runs of the same subroutine using a parameter to apply the different template.

Option Explicit

Sub runMacros()

    Dim Template1 As String, Template2 As String, Path As String, Folder As String

    Template1 = ThisWorkbook.Path & "RejectionLetterEmployee.docx"
    Template2 = ThisWorkbook.Path & "RejectionLetterEntrepreneur.docx"

    ' create path for documents
    Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
    Folder = Dir(Path, vbDirectory)

    If Folder = vbNullString Then
       MkDir Path
    End If

    ' create documents
    CreateDocuments "First", Template1, Path
    CreateDocuments "Second", Template2, Path
    MsgBox "Ended"

End sub

Sub CreateDocuments(Status As String, Template As String, SavePath)

    MsgBox "Running macro for Status = [" & Status & "] using " & Template & vbCrLf & _
           " into Folder " & SavePath, vbInformation

    Const StrNoChr As String = """*./\:?|"

    ' Paths and Filename
    Dim strMMSrc As String, strMMDoc As String, strMMPath As String
    Dim StrFileName As String, t0 As Single
    t0 = Timer

    ' open template
    Dim wdApp As New Word.Application, wdDoc As Word.Document, i As Integer, j As Integer
    Dim strName, MailSubjectName

    wdApp.Visible = False
    wdApp.DisplayAlerts = wdAlertsNone
    Set wdDoc = wdApp.Documents.Open( _
        Filename:=Template, _
        AddToRecentFiles:=False, _
        ReadOnly:=True, _
        Visible:=False)

    strMMSrc = ThisWorkbook.FullName ' datasource name

    With wdDoc.MailMerge
        .MainDocumentType = wdFormLetters
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True

        .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$` WHERE Status = '" & Status & "'"

        ' confirm to create docs
        If vbNo = MsgBox(.DataSource.RecordCount & " documents will be created in " & SavePath & _
                          ", continue ?", vbYesNo, "Confirm") Then
            GoTo skip
        End If

        ' create one doc for each record in datasource
        For i = 1 To .DataSource.RecordCount

            With .DataSource
                .FirstRecord = i
                .LastRecord = i
                .ActiveRecord = i

                strName = Trim(.DataFields("Name"))
                MailSubjectName = Trim(.DataFields("ID"))
                'Debug.Print "Raw", i, strName, MailSubjectName
                If strName = "" Then Exit For
            End With

            ' do merge
            .Execute Pause:=False

            ' construct doc filename to save
            ' replace illegal characters
            For j = 1 To Len(StrNoChr)
                strName = Replace(strName, Mid(StrNoChr, j, 1), "_")
                MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
            Next
            Debug.Print "Cleaned ", i, strName, MailSubjectName

            'Save to the folder that has been created by Path_Exists function
             StrFileName = SavePath & strName
            With wdApp.ActiveDocument
                .SaveAs Filename:=SavePath & strName & ".pdf", _
                         FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                .Close SaveChanges:=False
            End With

        Next i
        .MainDocumentType = wdNotAMergeDocument
    End With

    MsgBox i - 1 & " documents created in " & SavePath, vbInformation, "Completed in " & Int(Timer - t0) & " secs"

skip:
    ' cleanup
    wdDoc.Close SaveChanges:=False
    wdApp.DisplayAlerts = wdAlertsAll
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing

End Sub

Answer 2

In answering your question in passing parameters, there are a couple ways to do this. In the first example, create your vDat variable as a Range, then loop over the range and pass a range parameter.

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

But you actually created vDat as an array, so you can just pass the value of that row in the array:

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

What is not clear in your code and question is how the row relates to the DataSource or how you are using it in Macro1 or Macro2. I would also suggest renaming your macros to something more descriptive to what action the macro is performing.