Donate. I desperately need donations to survive due to my health

Get paid by answering surveys Click here

Click here to donate

Remote/Work from Home jobs

VBA to Google sheet script

Is there a fast way to possible convert a VBA code to Google sheet script?

Option Explicit

Const MODULE_NAME As String = "modMail"

Private fileCounter As Integer
Private activeSht As Worksheet

'Display all the files in a folder. Searches all the sub folders.

'Prints Folder Names in Column A and and the file Names in Column B
Sub SearchFiles()
 Dim pth As String
 Dim fso As FileSystemObject
 Dim baseFolder As Folder

'remove existing data

    Range("A12").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete
    Range("A12").Select
    On Error Resume Next

'define folder where macro should search for attachments (here: subfolder "output files" of directory with the macro)
 pth = ActiveWorkbook.Path & "\output files\"

 Set fso = New FileSystemObject

 ''check if the folder actually exists or not
 If (Not (fso.FolderExists(pth))) Then
 'the folder path is invalid.
 MsgBox "Invalid Path. Check if 'output files' sub-folder exists and has correct name"
 Exit Sub
 End If

 Set baseFolder = fso.GetFolder(pth)

 fileCounter = 1
    Set activeSht = ActiveSheet
    activeSht.Range("A2").FormulaR1C1 = "E-mail subject NL:"
    activeSht.Range("B2").FormulaR1C1 = "=""DEALER NAME""&'email addresses'!R[4]C[7]"
    activeSht.Range("A3").FormulaR1C1 = "E-mail subject EN:"
    activeSht.Range("B3").FormulaR1C1 = "=""DEALER NAME""&'email addresses'!R[1]C[7]"
    activeSht.Range("A4").FormulaR1C1 = "E-mail subject FR:"
    activeSht.Range("A5").FormulaR1C1 = "Send out form mailbox:"
    activeSht.Range("B5").FormulaR1C1 = "=IF('email addresses'!R[-4]C[7]=0,"""",'email addresses'!R[-4]C[7])"
    activeSht.Range("A6").FormulaR1C1 = "CC in every mail:"
    activeSht.Range("B6").FormulaR1C1 = "=IF('email addresses'!R[-4]C[7]=0,"""",'email addresses'!R[-4]C[7])"
    activeSht.Range("A7").FormulaR1C1 = "Copy Collector?"
    activeSht.Range("B7").FormulaR1C1 = ""
    activeSht.Range("A8").FormulaR1C1 = "Copy Team?"
    activeSht.Range("B8").FormulaR1C1 = ""
    activeSht.Range("A9").FormulaR1C1 = "Team`s mailbox:"
    activeSht.Range("B9").FormulaR1C1 = "=IF('email addresses'!R[-6]C[7]=0,"""",'email addresses'!R[-6]C[7])"
    activeSht.Range("A10").FormulaR1C1 = "Empty ""To"" fields:"
    activeSht.Range("B10").FormulaR1C1 = ""

    activeSht.Range("A11").Value = "Folder Name"
    activeSht.Range("B11").Value = "File Name"
    activeSht.Range("C11").Value = "Business Partner"

    Sheets("email addresses").Select
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Range("A1").Select
    Sheets("breaking-data").Select

 On Error GoTo ErrHandler
''' Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 PrintFileNames baseFolder


 'Once all the items are identified, copy the values into the list and remove duplicates
  Range("C12:C" & ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row).Select
  Selection.Copy
  Range("F12").Select
  ActiveSheet.paste
  Application.CutCopyMode = False
  ActiveSheet.Range("$F$12:$F$" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes

    'check Send From mailbox presence
    Dim msg6 As Integer

    If Sheets("email addresses").Range("I1").Value = 0 Then
    msg6 = MsgBox("'From:' mailbox address is not defined. Your default mailbox will be used. Continue?", vbYesNo + vbQuestion, "From: is empty")
    Sheets("breaking-data").Range("B5").FormulaR1C1 = "='email addresses'!R[-4]C[7]"
    If msg6 = vbNo Then
    Exit Sub
    Else
    Sheets("breaking-data").Range("B5").Value = "user default"
    End If
    End If


  'Populate list with email addresses from the emailaddress tab
  Dim lastrow As Long
  If Sheets("breaking-data").Range("F13").Value = vbNullString Then lastrow = 13 Else lastrow = Worksheets("breaking-data").Range("F12").End(xlDown).Row

'find dealer name
    Range("G12").Select
'    ActiveCell.FormulaR1C1 = "=MID(RC[-5], 12 , SEARCH("".xlsb"",RC[-5])-12)"
    Dim MidStart As Long
    Do
    MidStart = InStr(ActiveCell.Offset(0, -5), " ") + 1
    ActiveCell.FormulaR1C1 = "=MID(RC[-5]," & MidStart & ", SEARCH("".xlsb"",RC[-5])-" & MidStart & ")"
    ActiveCell.Offset(1, 0).Select
    Loop Until IsEmpty(ActiveCell.Offset(0, -1))
'find "To"
  Range("H12").Select
  ActiveCell.FormulaR1C1 = _
        "=IF(VLOOKUP(RC[-5],'email addresses'!R1C1:R5000C3,3,FALSE)="""",0,VLOOKUP(RC[-5],'email addresses'!R1C1:R5000C3,3,FALSE))"
  Range("H12").Select
  Range("H12").AutoFill Destination:=Range("H12:H" & lastrow&)

'define "CC1"
  Range("I12").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(VLOOKUP(RC[-6],'email addresses'!R1C1:R5000C4,4,FALSE) = 0,"""",VLOOKUP(RC[-6],'email addresses'!R1C1:R5000C4,4,FALSE))"
  Range("I12").Select
  Range("I12").AutoFill Destination:=Range("I12:I" & lastrow&)

'define "CC2" (WSA)?
  Dim msg3 As Integer
    msg3 = MsgBox("Would you like to copy Collector?", vbYesNo + vbQuestion, "Reminders - copy Collector?")
    If msg3 = vbYes Then
    Range("J12").FormulaR1C1 = _
        "=VLOOKUP(VLOOKUP(RC[-4],'email addresses'!C[-9]:C[-4],6,0),'email addresses'!C[-2]:C[-1],2,0)"
    Range("J12").Select
    Range("J12").AutoFill Destination:=Range("J12:J" & lastrow&)
    Range("B7").FormulaR1C1 = "Yes"
  Else
    Range("J12").FormulaR1C1 = Null
    Range("J12").Select
    Range("J12").AutoFill Destination:=Range("J12:J" & lastrow&)
    Range("B7").FormulaR1C1 = "No"
    End If

    If lastrow = 13 And Sheets("breaking-data").Range("F13").Value = vbNullString Then
    Range("G13:J13").ClearContents
    End If

  'copy CLSC?
  Dim msg4 As Integer
    msg4 = MsgBox("Would you like to copy Team`s mailbox?", vbYesNo + vbQuestion, "Reminders - copy Team`s mailbox?")
    If msg4 = vbYes Then
    Range("B8").FormulaR1C1 = "Yes"
    Else
    Range("B8").FormulaR1C1 = "No"
    End If

ErrHandler:
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic

'autofit rows
    Dim countIt As Integer
    Rows("12:12").Select
    countIt = Sheets("breaking-data").Cells(Sheets("breaking-data").Rows.Count, 1).End(xlUp).Row
    Rows("12:" & countIt).Select
    Selection.EntireRow.AutoFit
    Selection.Copy
    Selection.PasteSpecial paste:=xlPasteValues, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A12").Select

'count emtpy "To" fields
    Range("B10").Formula = "=COUNT(R[2]C[6]:R[" & countIt - 10 & "]C[6])+(COUNTA(R[2]C[4]:R[" & countIt - 10 & "]C[4])-COUNTA(R[2]C[6]:R[" & countIt - 10 & "]C[6]))"
    Range("A12").Select




End Sub

Sub PrintFileNames(baseFolder As Folder)

 Dim folder_ As Folder
 Dim file_ As File

 For Each folder_ In baseFolder.SubFolders
 'call recursive function.
 PrintFileNames folder_
 Next folder_

 For Each file_ In baseFolder.Files
 'print files here
    If (Right(file_.Name, 4) = "xlsb") Then
        activeSht.Range("A11").Offset(fileCounter, 0).Value = baseFolder.Path
        activeSht.Range("B11").Offset(fileCounter, 0).Value = file_.Name
        'activeSht.Range("C4").Offset(fileCounter, 0).Value = Mid(file_.Name, 32, 10)
        'activeSht.Range("D4").Offset(fileCounter, 0).Value = Left(file_.Name, 4)
'        activeSht.Range("C11").Offset(fileCounter, 0).Value = Left(file_.Name, 10)
        activeSht.Range("C11").Offset(fileCounter, 0).Value = Left(file_.Name, InStr(file_.Name, " ") - 1)
        fileCounter = fileCounter + 1
    Else
        'fileCounter = fileCounter + 1
    End If
 Next file_

End Sub



Sub emailInvoices(simulation As String)
    Dim cell As Range
    Dim curPath As String

    Dim loc_simulation As String
    loc_simulation = simulation

    Dim lstSales As Range
    Dim myList As Range

    Dim i As Long
'
'    Dim statementMonth As Integer
'    Dim statementYear As Integer
'
'    Dim currentDate As Date
'    Dim deferredDeliveryDate As Date
'
'    currentDate = DateAdd("m", -1, Now)
'    statementMonth = Format(currentDate, "m")
'    statementYear = Format(currentDate, "yyyy")

    'deferredDeliveryDate = DateAdd("d", 2, Now) 'delay time of 2 minutes before sending

'clear range extractionList
    Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents


'check empty To: fields
    Dim msg5 As Integer

    If Range("B10").Value > 0 Then
    msg5 = MsgBox("There is at least one empty field with 'To:' e-mail address. Would you like to continue?", vbYesNo + vbQuestion, "To: is empty")
        If msg5 = vbNo Then
    Range("A10").ClearContents
    Exit Sub
    Else
    Range("A10").ClearContents
    End If
    End If


'check if there are any attachments to send out
    Dim pth1 As String
    Dim fsc As FileSystemObject
    Dim objFiles As Files
    Dim lngFileCount As Long

    pth1 = ActiveWorkbook.Path & "\output files\" 'path to folder with attachments

    Set fsc = CreateObject("Scripting.FileSystemObject")
    Set objFiles = fsc.GetFolder(pth1).Files
    lngFileCount = objFiles.Count

    If lngFileCount = 0 Then
    MsgBox ("There is no attachment in sub-folder 'output files'")
    Exit Sub
    End If

    Set objFiles = Nothing
    Set fsc = Nothing

'define ranges for simulation/production run
'''    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    If loc_simulation = "Y" Then 'Use full range for prod run
        Set lstSales = Range("lstSalesman")
    ElseIf loc_simulation = "X" Then 'Use smaller range to perform test
        Set lstSales = Sheets("breaking-data").Range("F11:J16")
    End If

    Set myList = Sheets("breaking-data").Range("A11:C" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1)

'start loop for each line in table with contacts (in test for the first 5 lines)
    For i = 2 To lstSales.Rows.Count

'stop For if next line in 1stSales is empty
        If lstSales(i, 1) = "" Then
         Exit For
        End If

'copy details of attachment to extractList
        [valSalesman] = lstSales(i, 1)
        myList.AdvancedFilter Action:=xlFilterCopy, _
            criteriarange:=Range("Criteria"), copyToRange:=Range("Extract"), unique:=False


'EMAILING using OUTLOOK - Working in Excel 2000-2013

        Dim OutApp As Object
        Dim OutMail As Object

        Dim extractList As Range
        Set extractList = Sheets("breaking-data").Range("L11:N50")

        Dim CCForAll As Range
        Set CCForAll = Range("CCForAll")

        Dim CC_CLSC As Range
        Set CC_CLSC = Sheets("email addresses").Range("I3")

        Dim toMail As String
        Dim ccMail As String

'change Sent Items folder (not finished!!)
'Set Item.SaveSentMessageFolder = OutApp.Session.Folders("collections-ukroi@cnhind.com").Folders("Sent Items")

        toMail = lstSales(i, 3)
        If Sheets("breaking-data").Range("B8").Value = "Yes" Then
        ccMail = lstSales(i, 4) & "; " & lstSales(i, 5) & "; " & CCForAll & "; " & CC_CLSC
        Else
        ccMail = lstSales(i, 4) & "; " & lstSales(i, 5) & "; " & CCForAll
        End If

'open email template and copy contents
    Dim WDObj As Object
    Dim WDapp As Object
    Dim WDDoc As Object

'Email Template
    Dim language1 As String
    language1 = Application.WorksheetFunction.VLookup(lstSales(i, 1), Sheets("email addresses").Range("A:E"), 5, False)

    If language1 = "FR" Then
    Set WDObj = ThisWorkbook.Sheets("email addresses").OLEObjects("EmailTemplateFR")
    ElseIf language1 = "NL" Then
    Set WDObj = ThisWorkbook.Sheets("email addresses").OLEObjects("EmailTemplateNL")
    Else
    Set WDObj = ThisWorkbook.Sheets("email addresses").OLEObjects("EmailTemplateEN")
    End If

    WDObj.Activate
    WDObj.Object.Application.Visible = False

    Set WDapp = GetObject(, "Word.Application")
    Set WDDoc = WDapp.ActiveDocument

    WDDoc.Content.Copy

    WDDoc.Close SaveChanges:=False
'    WDapp.Quit

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next

'set up mailbox address, subject and mail body
        Dim Mailbox As String
        Dim Subject As String
        Dim attachmentPath As String

    Mailbox = Sheets("email addresses").Range("I1").Value
    If language1 = "FR" Then
    Subject = Sheets("email addresses").Range("I5").Value
    ElseIf language1 = "NL" Then
    Subject = Sheets("email addresses").Range("I6").Value
    Else
    Subject = Sheets("email addresses").Range("I4").Value
    End If

    attachmentPath = extractList(2, 1) & "\" & extractList(2, 2)

'compose e-mail
        With OutMail
        Dim DealerName As String
        DealerName = extractList(2, 4)
        .SentOnBehalfOfName = Mailbox
        .Subject = UCase(lstSales(i, 2)) & Subject
        .To = toMail
        .CC = ccMail
        .BCC = ""

        .Attachments.Add attachmentPath

'        .Attachments.Add extractList(2, 1) & "\" & extractList(2, 2)
        If loc_simulation = "Y" Then ' only kill the attachment when performing the production run
        Kill extractList(2, 1) & "\" & extractList(2, 2)
        End If


'        Next j

        .HTMLBody = ""
'        .Text
        .Display
'wait a bit before pasting message body from the template
        AppActivate (UCase(lstSales(i, 2)) & Subject & " - Message (HTML)")
        On Error GoTo 0
        Application.Wait (Now() + CDate("00:00:02"))
        SendKeys "^v", True
        SendKeys "^{HOME}", True
        Application.Wait (Now() + CDate("00:00:02"))

        'Simulation button
        If loc_simulation = "X" Then
        GoTo Clean_up:

        ElseIf loc_simulation = "Y" Then 'Production Run button
            '.DeferredDeliveryTime = deferredDeliveryDate 'defer delivery date
'wait a bit before pasting message body from the template
            Application.Wait (Now() + CDate("00:00:02"))
        .Send
'wait x seconds in the application before processing the next delivery
            Application.Wait (Now() + CDate("00:00:02"))
        Dim countMails As Long
        countMails = countMails + 1
        End If


    End With
    On Error GoTo 0

Clean_up:
    Range("A1").Select
    Selection.Copy
    Application.CutCopyMode = False


    Set OutMail = Nothing
    Set OutApp = Nothing
    Set WDObj = Nothing
    Set WDapp = Nothing

    ' END mailing routine

    'Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents
    Next i

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

' count reminders not picked up
    Dim fsc2 As FileSystemObject
    Dim objFiles2 As Files
    Dim lngFileCount2 As Long
    Dim pth As String

    pth = ActiveWorkbook.Path & "\output files\"

    Set fsc2 = CreateObject("Scripting.FileSystemObject")
    Set objFiles2 = fsc2.GetFolder(pth).Files
    lngFileCount2 = objFiles2.Count

    Sheets("breaking-data").Select
    Range("A1").Select
    AppActivate Application.Caption
    DoEvents
    If loc_simulation = "X" Then
        If MsgBox("Test mails prepared." & vbLf & "If all is fine go to Step 4 otherwise check data and run Step 1 again", vbQuestion) = vbQuestion Then
        GoTo End_it:
        End If

        ElseIf loc_simulation = "Y" Then
    If lngFileCount2 > 0 Then
    MsgBox ("There is/are: " & lngFileCount2 & "reminder(s) not picked up by the macro. Please check!")
    GoTo Delete_input:
    Else
    If MsgBox(countMails & " mails sent out." & vbLf & "If any remains open please check it for errors and send out manually.", vbQuestion) = vbQuestion Then
    GoTo Delete_input:
    End If
    End If
    End If

Delete_input:
    Dim msg2 As Integer

    If loc_simulation = "X" Then
        GoTo End_it:
    Else
    msg2 = MsgBox("Everything OK? Delete input data?", vbYesNo + vbQuestion, "Reminders delete input")
    If msg2 = vbYes Then
    Sheets("breaking-data").Select
    Range("B7").ClearContents
    Range("B8").ClearContents

    Range("A12").Select
    Range("A12:N" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1).Select
'    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete
    Range("A12").Select
    On Error Resume Next

    Application.DisplayAlerts = False
    Sheets("input").Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
    Worksheets.Add(Before:=Worksheets("email addresses")).Name = "input"
    End If
    End If

End_it:
    Sheets("breaking-data").Select
    Range("A1").Select
    ActiveWorkbook.Save
    SendKeys "{NUMLOCK}"
    SendKeys "{INSERT}"

End Sub

'' Validate email address
Public Function ValidateEmailAddress(ByVal strEmailAddress As String) As Boolean
    On Error GoTo Catch

    Dim objRegExp As New RegExp
    Dim blnIsValidEmail As Boolean
    objRegExp.IgnoreCase = True
    objRegExp.Global = True
    objRegExp.Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
    blnIsValidEmail = objRegExp.Test(strEmailAddress)
    ValidateEmailAddress = blnIsValidEmail
    Exit Function

Catch:    ValidateEmailAddress = False
MsgBox "Module: " & MODULE_NAME & " - ValidateEmailAddress function" & vbCrLf & vbCrLf _
        & "Error#:  " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Function

Ive been trying to make a script with google sheets to send a bulk of reminder to customers with a list of open invoices attached. I was able to make a script where the mails are sent to separate mail addresses, but unable to add an attachment. The problem that im experiencing

I was able to make the code below, but i'm having trouble adding the attachment. Also if there are multiple open invoices, there should only be 1 attachment made.

// This constant is written in column C for rows for which an email
// has been sent successfully.
var EMAIL_SENT = 'EMAIL_SENT';

/**
 * Sends non-duplicate emails with data from the current spreadsheet.
 */
function sendEmails2() {
  var sheet = SpreadsheetApp.getActiveSheet();
  var startRow = 2; // First row of data to process
  var numRows = 5; // Number of rows to process
  // Fetch the range of cells A2:B3
  var dataRange = sheet.getRange(startRow, 1, numRows, 3);
  // Fetch values for each row in the Range.
  var data = dataRange.getValues();
  for (var i = 0; i < data.length; ++i) {
    var row = data[i];
    var emailAddress = row[1]; // Second column
    var message = row[2]; // third column
    var subject = row[3]; // Fourth column
    var emailSent = row[5]; // Sixt column
    if (emailSent != EMAIL_SENT) { // Prevents sending duplicates
      MailApp.sendEmail(emailAddress, subject, message);
      sheet.getRange(startRow + i, 6).setValue(EMAIL_SENT);
      // Make sure the cell is updated right away in case the script is interrupted
      SpreadsheetApp.flush();
    }
  }
}

I've seen several add-ons, but these are all blacklisted by our administrator.

Comments