VBA for sending e-mails

A

aek_nikos

New Member
Joined
Jan 12, 2023
Messages
14
Office Version
  1. 2016
Platform
  1. Windows
Good morning
VBA Code: 
Function regexFind(strInput As String, strPattern As String) As Object    Dim regex As New RegExp    Dim regexMatch As Object    regex.Pattern = strPattern    regex.Global = True    Set regexMatch = regex.Execute(strInput)    If regexMatch.Count > 0 Then        Set regexFind = regexMatch.Item(0)    Else        Set regexFind = Nothing    End If End Function Sub SendEmails()    Dim regex As New RegExp    Dim sheetArrays(1 To 7) As Variant    sheetArrays(1) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_ANM")    sheetArrays(2) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_HSK")    sheetArrays(3) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_KTC")    sheetArrays(4) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_MNT")    sheetArrays(5) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_MSC")    sheetArrays(6) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_RCP")    sheetArrays(7) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_SRV")    Dim emailAddresses(1 To 7) As String    emailAddresses(1) = "ns@yahoo.gr"    emailAddresses(2) = "ns@yahoo.gr"    emailAddresses(3) = "ns@yahoo.gr"    emailAddresses(4) = "ns@yahoo.gr"    emailAddresses(5) = "ns@yahoo.gr"    emailAddresses(6) = "ns@yahoo.gr"    emailAddresses(7) = "ns@yahoo.gr"    Dim i As Integer    For i = 1 To 7        Dim wsArray As Variant        wsArray = sheetArrays(i)        Dim wb As Workbook        Set wb = ThisWorkbook        Dim tempWB As Workbook        Set tempWB = Workbooks.Add(xlWBATWorksheet)        Dim j As Integer        For j = LBound(wsArray) To UBound(wsArray)            wb.Sheets(wsArray(j)).Copy after:=tempWB.Sheets(tempWB.Sheets.Count)        Next j        Dim tempFilePath As String        tempFilePath = Environ$("temp") & "\" & wsArray(UBound(wsArray)) & ".xlsx"        Application.DisplayAlerts = False 'turn off prompt for delete sheet1        tempWB.Sheets(1).Delete 'delete sheet1        Application.DisplayAlerts = True 'turn on prompt for other alerts        ' Update formula references        Dim editableSheet As Worksheet        Set editableSheet = tempWB.Sheets(wsArray(UBound(wsArray)))        Dim cell As Range        Dim regexPattern As String: regexPattern = "\[[^\]]+\]" ' pattern to match external file path        For Each cell In editableSheet.UsedRange            If InStr(cell.Formula, "[") > 0 Then                Dim regexMatches As Object                Set regexMatches = regex.Execute(cell.Formula)                If Not regexMatches Is Nothing Then                    Dim formulaWithoutExternalRef As String                    formulaWithoutExternalRef = cell.Formula                    For Each regexMatch In regexMatches                        formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, regexMatch.Value, "")                    Next regexMatch                    formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, ",", ";") ' Replace commas with semicolons                    formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, "[", "") ' Remove opening square brackets                    formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, "]", "") ' Remove closing square brackets                    cell.Formula = formulaWithoutExternalRef                End If            End If        Next cell    tempWB.SaveAs tempFilePath        Dim outlookApp As Object    Set outlookApp = CreateObject("Outlook.Application")        Dim outlookMail As Object    Set outlookMail = outlookApp.CreateItem(0)    With outlookMail        .To = emailAddresses(i)        .subject = "Your subject here"        .Body = "Your message here"        .Attachments.Add tempFilePath        .Send    End With        tempWB.Close savechanges:=False    Kill tempFilePath 'delete the temp file Next i     End Sub

this is a try to write a VBA code that defines an array of sheet names and an array of email addresses., then loops through each element in the sheet array, creates a new workbook, copies the specified sheets from the current workbook to the new workbook, updates formula references in the new workbook to remove any external references and replace commas with semicolons, saves the new workbook to a temporary file path, and then creates an email with the specified subject, message, and attachment and sends it to the corresponding email address. All parts work except the part that removes all external references to formulas.
Can you please help me adjust the code i am sending in order to be able to remove all external references in formulas from all sheets and keeps formulas working?
i.e this: =[2023_PROTOTYPE_VALIDATION_VBAcheck.xlsm]AB_ANM!A4
should be: =AB_ANM!A4
but this: =SUM(B3:H3)
should be kept as it is.
plus all formulas are written with ";" as semicolons and this is the correct form that should be kept because this is the version's i use requirements.

The part that's not working is:
VBA Code: 
' Update formula references
Dim editableSheet As Worksheet
Set editableSheet = tempWB.Sheets(wsArray(UBound(wsArray)))
Dim cell As Range
Dim regexPattern As String: regexPattern = "\[[^\]]+\]" ' pattern to match external file path
For Each cell In editableSheet.UsedRange
    If InStr(cell.Formula, "[") > 0 Then
        Dim regexMatches As Object
        Set regexMatches = regex.Execute(cell.Formula)
        If Not regexMatches Is Nothing Then
            Dim formulaWithoutExternalRef As String
            formulaWithoutExternalRef = cell.Formula
            For Each regexMatch In regexMatches
                formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, regexMatch.Value, "")
            Next regexMatch
            formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, ",", ";") ' Replace commas with semicolons
            cell.Formula = formulaWithoutExternalRef
        End If
    End If
Next cell
It was supposed to totally remove external references inside formulas but it doesn't. Any ideas?

Thanks a lot
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
One code example ended up on one line, so not readable. If the wb name was always the same you could just use Replace function? If it's not but it always ends in ] then
- look for ], not [
- take Mid from that point (+1)
So
mid("[2023_PROTOTYPE_VALIDATION_VBAcheck.xlsm]AB_ANM!A4",instr("[2023_PROTOTYPE_VALIDATION_VBAcheck.xlsm]AB_ANM!A4","]")+1) returns
AB_ANM!A4

(use string variable formulaWithoutExternalRef As?)
I wouldn't bother with RegEx if I could help it. Not sure why you think you need it; perhaps there is more that was not revealed. FWIW, you variable names are too long. Better to
VBA Code: 
Dim strNewName As String 'and if you need it, put a comment that explains it
 
Upvote 0
Good morning, appreciate your answer. This is the full code:

VBA Code: 
Function regexFind(strInput As String, strPattern As String) As Object
    Dim regex As Object
    Dim regexMatch As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = strPattern
    regex.Global = True
    Set regexMatch = regex.Execute(strInput)
    If regexMatch.Count > 0 Then
        Set regexFind = regexMatch.Item(0)
    Else
        Set regexFind = Nothing
    End If
End Function
Sub SendEmails()
    Dim sheetArrays(1 To 7) As Variant
    sheetArrays(1) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_ANM")
    sheetArrays(2) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_HSK")
    sheetArrays(3) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_KTC")
    sheetArrays(4) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_MNT")
    sheetArrays(5) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_MSC")
    sheetArrays(6) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_RCP")
    sheetArrays(7) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_SRV")

    Dim emailAddresses(1 To 7) As String
    emailAddresses(1) = "@yahoo.gr"
    emailAddresses(2) = "@yahoo.gr"
    emailAddresses(3) = "@yahoo.gr"
    emailAddresses(4) = "@yahoo.gr"
    emailAddresses(5) = "@yahoo.gr"
    emailAddresses(6) = "@yahoo.gr"
    emailAddresses(7) = "@yahoo.gr"

    Dim i As Integer
    For i = 1 To 7
        Dim wsArray As Variant
        wsArray = sheetArrays(i)

        Dim wb As Workbook
        Set wb = ThisWorkbook

        Dim tempWB As Workbook
        Set tempWB = Workbooks.Add(xlWBATWorksheet)

        Dim j As Integer
        For j = LBound(wsArray) To UBound(wsArray)
            wb.Sheets(wsArray(j)).Copy after:=tempWB.Sheets(tempWB.Sheets.Count)
        Next j

        Dim tempFilePath As String
        tempFilePath = Environ$("temp") & "\" & wsArray(UBound(wsArray)) & ".xlsx"

        Application.DisplayAlerts = False 'turn off prompt for delete sheet1
        tempWB.Sheets(1).Delete 'delete sheet1
        Application.DisplayAlerts = True 'turn on prompt for other alerts

        ' Update formula references
        Dim editableSheet As Worksheet
        Set editableSheet = tempWB.Sheets(wsArray(UBound(wsArray)))
        Dim cell As Range
        Dim regexPattern As String: regexPattern = "\[[^\]]+\]" ' pattern to match external file path
        For Each cell In editableSheet.UsedRange
            If InStr(cell.Formula, "[") > 0 Then
                Dim regexMatch As Object
                Set regexMatch = regexFind(cell.Formula, regexPattern)
                If Not regexMatch Is Nothing Then
                    Dim formulaWithoutExternalRef As String
                    formulaWithoutExternalRef = Replace(cell.Formula, regexMatch.Value, "")
                    formulaWithoutExternalRef = Replace(formulaWithoutExternalRef, ",", ";") ' Replace commas with semicolons
                    cell.Formula = formulaWithoutExternalRef
                End If
            End If
    Next cell
    tempWB.SaveAs tempFilePath
    
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    
    Dim outlookMail As Object
    Set outlookMail = outlookApp.CreateItem(0)
    With outlookMail
        .To = emailAddresses(i)
        .subject = "subject"
        .Body = "message"
        .Attachments.Add tempFilePath
        .Send
    End With
    
    tempWB.Close savechanges:=False
    Kill tempFilePath 'delete the temp file
Next i
    
End Sub


Sorry about the one line issue, my mistake. The purpose of the RegEx is to search for the pattern but to tell you the truth i messed up the code and now i am desperate and struggling. Any help would be highly appreciated>
Thanks in advance
 
Upvote 0
Not sure what to tell you. I raised an "IF" scenario that you didn't address thus I have no idea what the strInput looks like beyond your one example. If it is as I surmised then what I posted should work.
As for RegEx, ROF's (retired old farts) like me who are not freelancing and don't understand it don't have much incentive to learn. Thus unfortunately, I cannot validate your pattern but I did come up with something else less complicated that works but it's based on limited information.
 
Upvote 0
VBA Code: 
Sub SendEmails()
    Dim sheetArrays(1 To 7) As Variant
    sheetArrays(1) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_ANM")
    sheetArrays(2) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_HSK")
    sheetArrays(3) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_KTC")
    sheetArrays(4) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_MNT")
    sheetArrays(5) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_MSC")
    sheetArrays(6) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_RCP")
    sheetArrays(7) = Array("PAVLIDIS", "HOURS", "CODE_CLC", "ALL", "LIST", "SCHE_CLC", "MASTER_HOURS", "AB_SRV")

    Dim emailAddresses(1 To 7) As String
    emailAddresses(1) = "@yahoo.gr"
    emailAddresses(2) = "@yahoo.gr"
    emailAddresses(3) = "@yahoo.gr"
    emailAddresses(4) = "@yahoo.gr"
    emailAddresses(5) = "@yahoo.gr"
    emailAddresses(6) = "@yahoo.gr"
    emailAddresses(7) = "@yahoo.gr"

    Dim i As Integer
    For i = 1 To 7
        Dim wsArray As Variant
        wsArray = sheetArrays(i)

        Dim wb As Workbook
        Set wb = ThisWorkbook

        Dim tempWB As Workbook
        Set tempWB = Workbooks.Add(xlWBATWorksheet)

        Dim j As Integer
        If Not IsEmpty(wsArray) And Not IsNull(wsArray) Then
            For j = LBound(wsArray) To UBound(wsArray)
                On Error Resume Next
                wb.Sheets(wsArray(j)).Copy after:=tempWB.Sheets(tempWB.Sheets.Count)
                If Err.Number <> 0 Then
                    Debug.Print "Error occurred while copying sheet: " & Err.Description
                End If
            On Error GoTo 0
        Next j
    Else
        Debug.Print "Error: wsArray is empty or null."
    End If
        Dim tempFilePath As String
        tempFilePath = Environ$("temp") & "\" & wsArray(UBound(wsArray)) & ".xlsx"

        Application.DisplayAlerts = False 'turn off prompt for delete sheet1
        tempWB.Sheets(1).Delete 'delete sheet1
        Application.DisplayAlerts = True 'turn on prompt for other alerts
        tempWB.SaveAs tempFilePath
        Dim outlookApp As Object
        Set outlookApp = CreateObject("Outlook.Application")
        Dim outlookMail As Object
        Set outlookMail = outlookApp.CreateItem(0)
        With outlookMail
            .To = emailAddresses(i)
            .subject = "Your subject here"
            .Body = "Your message here"
            .Attachments.Add tempFilePath
            .Send
        End With
        tempWB.Close savechanges:=False
        Kill tempFilePath 'delete the temp file
    Next i
End Sub
This is the correct part of the code that works and I want to keep it. My problem is to add a way that it finds all external references inside all formulas in all sheets and removes them. So far i came with 100 different solutions and hours of trying and couldn't do it. Problem is my knowledge is until a certain limit. Any help is welcome
 
Upvote 0
You seem to be missing the point. Posting more code doesn't clear up anything I've asked about, such as what the inputs look like or where they're coming from. All you're showing is how you're dealing with the inputs. So I'll just suggest that your function could possibly be as simple as
VBA Code: 
Function RemoveReference(strInput As String) As String

RemoveReference = mid(strInput ,instr(strinput,"]")+1)
End Function
If not then it has to be because of the (still) unknowns.
 
Upvote 0
You must log in or register to reply here.

Similar threads

ToseSenpai
  • Solved
Send mail with custom attachment active sheet (VBA)
Replies
3
Views
3K
DanteAmor
DanteAmor
R
  • Question Question
VBA Send All if
Replies
2
Views
461
Ruca13
R
K
  • Question Question
VBA to select multiple ranges and send e-mail
Replies
0
Views
3K
KSAExcel
K
M
  • Question Question
Sending chart in e-mail body using Excel VBA
2
Replies
15
Views
60K
mahmed1
M
S
  • Question Question
Auto-Schedule Macros to Run, vba send E-mail without Outlook error message, getting around Access queries with parameters
Replies
2
Views
43K
Derek Brown
D

Forum statistics

Threads
1,223,871
Messages
6,175,095
Members
452,612
Latest member
MESTeacher

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top