VBA code clean up

E

Elliottj2121

Board Regular
Joined
Apr 15, 2021
Messages
56
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hello Everyone!

I have a macro written and it works exactly how I would like it to work. However, I am newer at writing macros and my skills are very limited so I go on this forum and others to piece together bits of code here and there to make what I need to do work. I have the macro code listed below and it seems to run a little slow. Could someone be my "editor" and clean it up so it is more efficient and a little more polished?

I am taking a worksheet in excel with customer data and creating a table in an outlook email for each customer to email a summary of their invoices. I have example data below also. Thank you in advance!

VBA Code: 
Sub EMAIL_10th_PAYORS()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    ProperCNCN
    i45Email
    Condense
    Save_List
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub ProperCNCN()

Dim wsProper As Worksheet
Set wsProper = ActiveWorkbook.Worksheets(1)
Dim lProperLastRow As Long, c As Range, n As Range, t As Range
Dim CustNameRange As Range, ContNameRange As Range
Dim lCustNameRange As String, lContNameRange As String
Dim LR As Long
LR = ProperLastRow(wsProper)
lProperLastRow = ProperLastRow(wsProper)
   
    Set CustNameRange = Range("B2:B" & lProperLastRow)
    Set ContNameRange = Range("H2:H" & lProperLastRow)

    For Each c In CustNameRange
        c.Value = Application.WorksheetFunction.Proper(c.Value)
    Next c
   
    For Each n In ContNameRange
        n.Value = Application.WorksheetFunction.Proper(n.Value)
    Next n
    With wsProper
        .Cells.NumberFormat = "General"
        .Columns("I:S").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Columns(8).TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
            TextQualifier:=xlNone, ConsecutiveDelimiter:=True, Tab:=False, Semicolon _
            :=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array( _
            Array(1, 1), Array(2, 9), Array(3, 9), Array(4, 9)), TrailingMinusNumbers:=True
        .Columns("I:S").Delete Shift:=xlToLeft
        .Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("H1").FormulaR1C1 = "Total"
        .Range("H2").FormulaR1C1 = _
            "=IF(RC[-7]<>R[1]C[-7],SUMIFS(R1C[-2]:RC[-2],R1C[-7]:RC[-7],RC[-7]),"""")"
        .Range("H2").AutoFill Range("H2:H" & LR)
        .Columns("H").NumberFormat = "General"
        .Columns("F").Style = "Currency"
        .Columns("H").Style = "Currency"
        .Columns.AutoFit
    End With
End Sub

Private Sub i45Email()


 Set rng = Range(Range("J2"), Range("J" & Rows.Count).End(xlUp))
  x = rng.Rows.Count
    tableHdr = "<table border=1 style=border-collapse:collapse><tr><th width=101 style='width:76.1pt;padding:.75pt .75pt .75pt .75pt;background-color:#1C6EA4'><p align=center style='text-align:center'><font color='white'><b>" & Range("C1").Value & "</b></font></th>" _
            & "<th width=101 style='width:76.1pt;padding:.75pt .75pt .75pt .75pt;background-color:#1C6EA4'><p align=center style='text-align:center'><font color='white'><b>" & Range("D1").Value & "</b></font></th>" _
            & "<th width=101 style='width:76.1pt;padding:.75pt .75pt .75pt .75pt;background-color:#1C6EA4'><p align=center style='text-align:center'><font color='white'><b>" & Range("E1").Value & "</b></font></th>" _
            & "<th width=101 style='width:76.1pt;padding:.75pt .75pt .75pt .75pt;background-color:#1C6EA4'><p align=center style='text-align:center'><font color='white'><b>" & Range("F1").Value & "</b></font></th>" _
            & "<th width=101 style='width:76.1pt;padding:.75pt .75pt .75pt .75pt;background-color:#1C6EA4'><p align=center style='text-align:center'><font color='white'><b>" & Range("G1").Value & "</b></font></th>" _
            & "<th width=101 style='width:76.1pt;padding:.75pt .75pt .75pt .75pt;background-color:#1C6EA4'><p align=center style='text-align:center'><font color='white'><b>" & Range("H1").Value & "</b></font></th>" _
   
    For Each Cell In rng
    If Cell.Value <> "" Then
    If Not Cell.Offset(0, 1).Value = "yes" Then
    NmeRow = Cell.Row
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Para1 = "We will be processing a payment for the invoices listed below on 10th of this month or the next business day after the 10th."

    MailTo = Cell.Value
    MailSubject = "Monthly payment for" & " " & Cell.Offset(0, -8).Value
    filename = Cell.Offset(0, -6).Value & "_" & Format(Date, "mm") + 1 & ".10." & Format(Date, "yy")
   
    Greeting = "<p><span style='font-size:12.0pt;font-family:'Times New Roman',serif'>Hello" & " " & Cell.Offset(0, -1).Value & "," & "</span></p>"
   
    Message = "<p><span style='font-size:12.0pt;font-family:'Times New Roman',serif'>" & Para1 & "</p>" & "</span></p>"
   
   

    MailBody = "<tr>" _
            & "<td align=center style='text-align:center'>" & Cell.Offset(0, -7).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & Cell.Offset(0, -6).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & Cell.Offset(0, -5).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & Cell.Offset(0, -4).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & Cell.Offset(0, -3).Value & "</td>" _
            & "<td span class='dollars' align=center style='text-align:center'>" & Cell.Offset(0, -2).Value & "</td>" _
            & "</tr>"

    For Each dwn In rng.Offset(NmeRow - 1, 0)
    If dwn.Value = Cell.Value Then
    AddRow = "<tr>" _
            & "<td align=center style='text-align:center'>" & dwn.Offset(0, -7).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & dwn.Offset(0, -6).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & dwn.Offset(0, -5).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & dwn.Offset(0, -4).Value & "</td>" _
            & "<td align=center style='text-align:center'>" & dwn.Offset(0, -3).Value & "</td>" _
            & "<td span class='dollars' align=center style='text-align:center'>" & dwn.Offset(0, -2).Value & "</td>" _
            & "</tr>"

    dwn.Offset(0, 1).Value = "yes"
    MailBody = MailBody & AddRow  'column A
    End If

    AddRow = ""
    Next
        With OutMail
            .To = MailTo
            .Subject = MailSubject
            .HTMLBody = "<html>" & Logo & Greeting & Message & tableHdr & MailBody & "</table>" & Break & "</html>"
            .Save
            '.Close
            '.Display
            '.Send
       End With
       
    Cell.Offset(0, 1).Value = "yes"
 
  End If
 End If
 
 
MailTo = ""
MailSubject = ""
MailBody = ""
Next
 Range("K2:K" & x).ClearContents
End Sub
Private Sub Condense()
Dim r As Long
Dim TR As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets(1)
LR = ProperLastRow(ws)
Set TR = Range("H2:H" & LR)

Columns("H:H").Copy
Columns("H:H").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
   
For r = TR.Cells.Count To 1 Step -1
    With TR.Cells(r)
    If .Value = "" Then
    .EntireRow.Delete
    End If
    End With
Next r

Columns("C:G").Delete
Columns("D:G").Delete

End Sub
Private Sub Save_List()
Dim filename As String, path As String, FNS As String

filename = Format(Date, "mm") & ".10_LIST"
path = "U:\Company Shares\DC Office Shares\Credit\Credit File\ACH Payments\Pending ACH\"
ActiveWorkbook.SaveAs filename:=path & filename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close


End Sub



Function ProperLastRow(sh As Worksheet) As Variant
  On Error Resume Next
  ProperLastRow = sh.Cells.Find(What:="*", _
                        lookat:=xlWhole, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
                       
End Function

Customer #CustomerInv#DateAgeAmountPOContactEmail
100Alpha Company11099716/7/2024181854.55Alpha8Joealphaco@anymail.com
100Alpha Company11099726/7/2024181423.79Alpha8Joealphaco@anymail.com
100Alpha Company11099736/7/2024181187.33Alpha8Joealphaco@anymail.com
100Alpha Company11102546/7/202418324.82Alpha8Joealphaco@anymail.com
101Beta Inc.11103066/7/20241830.24Beta9MikeBeta@anymail.com
101Beta Inc.11107066/11/202414181.44Beta10MikeBeta@anymail.com
102Gamma LLC11099686/12/20241310015.19Gamma88PaulGamma@anymail.com
102Gamma LLC11122906/13/2024122451.8Gamma88PaulGamma@anymail.com
102Gamma LLC24160606/3/202422238.09Gamma101PaulGamma@anymail.com
102Gamma LLC24166446/4/202421602.47Gamma101PaulGamma@anymail.com
103Delta LLP24160636/10/202415853.17456123JohnDelta@anymail.com
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
It is hard to work with a picture. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
The first thing you should consider doing is adding some code to measure execution time. This will help you to find the slow parts. As an example, I have added timer code to one of your subroutines:

VBA Code: 
Private Sub Save_List()
    Dim filename As String, path As String, FNS As String
  
    'Code to time execution
    Dim StartTime As Single
    StartTime = Timer
  
  
  
    filename = Format(Date, "mm") & ".10_LIST"
    path = "U:\Company Shares\DC Office Shares\Credit\Credit File\ACH Payments\Pending ACH\"
    ActiveWorkbook.SaveAs filename:=path & filename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close
  
    'The next line displays execution time in the VBA Debugger "Immediate" window
    Debug.Print "Elapsed Time for Sub/Function Save_List: " & Timer - StartTime
End Sub

How to use the Immediate window:
5 Ways to Use the VBA Immediate Window - Excel Campus
 
Upvote 0
mumps said:
It is hard to work with a picture. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
Click to expand...
Mumps,

I am confused by your post, can you please explain more? There are no pictures and I used XL2BB and provided specific details of what I was looking for.
 
Upvote 0
My apologies. Give me a little time to have a closer look.
 
Upvote 0
In the ProperCNCN macro, you insert columns and then use TextToColumns and then delete the same columns. Why insert the columns and then delete them? Please clarify. What is the range that you want to insert into the email?
 
Upvote 0
mumps said:
In the ProperCNCN macro, you insert columns and then use TextToColumns and then delete the same columns. Why insert the columns and then delete them? Please clarify. What is the range that you want to insert into the email?
Click to expand...
In the original data set, the contact name column might say "JOHN SMITH" or "BILL JONES". What I want is for the contact name column to just say "John" or "Bill". It was the only way I knew how to achieve this without data loss. Make more columns, do the text-to-columns function to separate John & Smith and Bill & Jones Then deleting the last name column. If there is a better way, I am all ears.
 
Upvote 0
Will the name always be just firstname/lastname or can it be lastname/firstname? What is the range that you want to insert into the email? Could you post some data that is more representative of your actual data that includes both names?
 
Upvote 0
Below is a more accurate example of the Contact Name column. In our database/ERP sometimes the contact name field could have other information in it due to space constraints on other fields. It will always be firstname/lastname in the database field. The only other example that is not listed below is sometimes it is just a first name only. But it always is first name then last name or title or email or a combination.

Customer #CustomerInv#DateAgeAmountPOContactEmail
100Alpha Company11099716/7/2024181854.55Alpha8Joe Smithalphaco@anymail.com
100Alpha Company11099726/7/2024181423.79Alpha8Joe Smithalphaco@anymail.com
100Alpha Company11099736/7/2024181187.33Alpha8Joe Smithalphaco@anymail.com
100Alpha Company11102546/7/202418324.82Alpha8Joe Smithalphaco@anymail.com
101Beta Inc.11103066/7/20241830.24Beta9Mike Jones mjones@anymail.comBeta@anymail.com
101Beta Inc.11107066/11/202414181.44Beta10Mike Jones mjones@anymail.comBeta@anymail.com
102Gamma LLC11099686/12/20241310015.19Gamma88Paul A/PGamma@anymail.com
102Gamma LLC11122906/13/2024122451.8Gamma88Paul A/PGamma@anymail.com
102Gamma LLC24160606/3/202422238.09Gamma101Paul A/PGamma@anymail.com
102Gamma LLC24166446/4/202421602.47Gamma101Paul A/PGamma@anymail.com
103Delta LLP24160636/10/202415853.17456123John or SallyDelta@anymail.com


Regarding the fields that am looking to copy over to the email. It would Columns C, D, E, F, & G along with a total of the invoice amount. Below is an example of what the end result should be. it is just the basic data and not the formatting with header colors etc. I have included an image of how the email should look with "Alpha Company's" invoices and info.

Inv#DateAgeAmountPOTotal
11099716/7/2024181854.55Alpha8
11099726/7/2024181423.79Alpha8
11099736/7/2024181187.33Alpha8
11102546/7/202418324.82Alpha84790.49
 

Attachments

  • Alpha co example.png
    Alpha co example.png
    23.6 KB · Views: 7
Upvote 0
Try:
VBA Code: 
Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, sPath As String
    Dim wsProper As Worksheet, lRow As Long, v2 As Variant, arr() As Variant, i As Long, x As Long
    sPath = "C:\RemoteAMBA\bin\SoftTokens\"
    Set wsProper = Sheets(1)
    With wsProper
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        v2 = Range("I2:I" & lRow).Value
        For i = LBound(v2) To UBound(v2)
            x = x + 1
            ReDim Preserve arr(1 To x)
            arr(x) = Split(v2(i, 1), " ")(0)
        Next i
        Range("H2").Resize(UBound(v2)) = Application.Transpose(arr)
        .Columns(9).Delete
        .Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("H1").FormulaR1C1 = "Total"
        .Range("H2").FormulaR1C1 = "=IF(RC[-7]<>R[1]C[-7],SUMIFS(R1C[-2]:RC[-2],R1C[-7]:RC[-7],RC[-7]),"""")"
        .Range("H2").AutoFill Range("H2:H" & lRow)
        .Columns("H").NumberFormat = "General"
        .Columns("F").Style = "Currency"
        .Columns("H").Style = "Currency"
        .Columns.AutoFit
        .ListObjects.Add(xlSrcRange, .Range("A1:J" & lRow), , xlYes).Name = "Table1"
        Set rng = .Range("C1:H" & lRow).SpecialCells(xlVisible)
        .Range("C2").AutoFilter
    End With
    Set OutApp = CreateObject("Outlook.Application")
    v = wsProper.Range("B2", wsProper.Range("B" & Rows.Count).End(xlUp)).Resize(, 10).Value
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With wsProper
                    .Range("A1").CurrentRegion.AutoFilter 2, v(i, 1)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(i, 9)
                        .Subject = "Monthly Payment for " & v(i, 1)
                        .HTMLBody = "Hello " & v(i, 8) & "," & "<br><br>" & "We will be processing a payment for the invoic es listed below on the 10th of this month." & "<br><br>" & RangetoHTML(rng)
                        .Display
                    End With
                End With
            End If
        Next i
    End With
    wsProper.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    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"
    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
    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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Adding a custom message.
Replies
1
Views
671
Micron
M
P
  • Question Question
putting a snippet of code from one to another somehow
Replies
5
Views
321
Patriot2879
P
D
  • Solved
VBA Function to Paste Table into Outlook Email Resulting in HTML language in Email
Replies
8
Views
642
smozgur
smozgur
J
  • Question Question
Send bulk email attachment error
Replies
3
Views
113
JOHATUP
J
D
  • Question Question
VBA to Create Outlook Email Not Working for All Users
Replies
9
Views
364
Logit
Logit

Forum statistics

Threads
1,224,812
Messages
6,181,088
Members
453,021
Latest member
Justyna P

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