Populating recipient name in Outlook email

I created a vb macro to send emails to listed people in an excel file with their corresponding data table.

Everything is working fine just one problem! After many efforts I could not get/ write a code to get Name of the recipient after Hello in strbody.

Here is the sample file Click here

Link to RangetoHTML function Click here (it needs to be pasted after end sub in below code)

Below is has been fixed and working now. refer to the sample filefor column arrangement

Sub Credit_Auto()

 Dim test1 As Long, test2 As Long
 test1 = Timer
 Application.ScreenUpdating = False

'This code populates emails to outlook as per the Credit analysts.

    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim SigString As String
    Dim Signature As String
    Dim name_rg As Range
    Dim name As String

    Set OutApp = CreateObject("Outlook.Application")

 'You may want to change the signature file path below to get your signature properly

    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Pratik Kumar2.htm"

    If Dir(SigString) <> "" Then
    Signature = GetBoiler(SigString)
        Signature = ""
    End If

    On Error Resume Next

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:G" & Ash.Rows.Count)
    FieldNum = 7   

    'Add a worksheet for the unique list and copy the unique list in A1

    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value

            'If the unique value is a mail address create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With

                Set OutMail = OutApp.CreateItem(0)

    'Search email address from Cws into Ash ~
    Set name_rg = Ash.Columns(7).Find(Cws.Cells(Rnum, 1))

    If Not name_rg Is Nothing Then
     'input the row index of <name_rg>
     'returns the name from col 6 ~
      name = Ash.Cells(name_rg.Row, 6)
     name = "email not found in Ash"
    End If

    Set name_rg = Nothing

    strbody = "Hello " & name & "," & "<br>" & "<br>" & _
              "Please allocate the below account(s) to it's appropriate parent account." & "<br>"

    On Error GoTo Cleanup

                On Error Resume Next

                With OutMail
                    .to = Cws.Cells(Rnum, 1).Value
                    .Subject = "Unallocated Credit Account"
                    .HTMLBody = strbody & RangetoHTML(rng) & "<br>" & Signature
                End With

                Set Ws = Nothing

                On Error GoTo 0

                Set OutMail = Nothing
            End If

            'Close AutoFilter
            Ash.AutoFilterMode = False

        Next Rnum
    End If

    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    test2 = Timer
    MsgBox "All the Credit Analysts have been notified and the entire process took " & Format((test2 - test1) / 86400, "hh:mm:ss") & " Seconds."

End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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"

    'Copy the range and create a new workbook to past the data in
    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
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
Selection.Delete Shift:=xlToLeft
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
End Function

Update original data from pivot table? [on hold]

Objective: To update a column in the original data set from a pivot table

The Question: There is a requirement to update the original data set from a pivot table that is based on the same original data set.

How can I achieve this?

Further explanation:

The way that I think it should happen

How do I get values added in the RYG column of the pivot table to reflect in the Original data set? The RYG column in the original data set is empty

Changing font color in cell on double-click

In Excel (using VBA) I want to change the color of the check marks from gray to green on double-click, then back to gray again on double-click (basically a toggle). Current code is below – NOTHING I have tried has worked. Please help.

Here is the image. The font is Wingdings, character code is 252, font colors are #BEBEBE and #008000. I want those gray check marks to change to green on double click and if double clicked again, back to gray. This is in a range of cells (B7 to C150).



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 2 Then
Cancel = True
End If

If Target.Column = 3 Then
Cancel = True
End If

With Target.Font.Color
    If Not .Font.Color = vb15 Then
        .ColorIndex = vb10
    ElseIf Not .Font.Color = vb10 Then
        .ColorIndex = vb15
    End If
End With

End Sub

Thanks for any help!!

Copy and Paste dynamic range between worksheets

I have data from multiple worksheets that need to be aggregated to multiple worksheets based on some source file name. All my data is stored in A16:C115 in the source. I want to aggregate that data into the appropriate worksheet, stacking the data (i.e. set 1- A1:C100, set 2- A101,C200). This data size can be variable between workbooks, so that is why I am using Cells and offsets/rows/col counters.

'dest: name of worksheet for data to be pasted into
'src:  data source worksheet
'offset:  current count of data sources that have been pasted, indexed 0
'rows: row count to be pasted
'col:  column count to be pasted

Sub addTrend(dest As Variant, src As Worksheet, offset As Integer, rows As Integer, col As Integer)

    Debug.Print CStr(dest), offset, rows, col
    src.Range(Cells(16, 1), Cells(15 + rows, col)).Copy (Worksheets(CStr(dest)).Range(Cells((offset * rows) + 1, 1), Cells((offset + 1) * rows, col)))

End Sub

The result of this code is that nothing is pasted into the destination worksheet. Due to reasons below, I am pretty sure the error in my code is in the copy/paste line. As mentioned above, I feel this copy and paste function is written to accomplish the desired behavior, but maybe I am missing something. Any ideas?

Copy/Paste line attempts with no effect:

src.Range(Cells(16, 1), Cells(15 + rows, col)).Copy Worksheets(CStr(dest)).Range("A" & (offset * rows) + 1)


I’ve tested (not shown) that the worksheet dest can be found (iterating all open worksheets and comparing the name). I’ve tested that the source worksheet is also found (by writing to a cell). The offset is counting correctly, the rows/cols are appropriate.

Here is a snippet of the debug print line:

dapSNVHeight                11             100           3 
dapSNVHeight                12             100           3 
dapSNVHeight                13             100           3 
detAvgPeakHeight             0             100           3 
detAvgPeakHeight             1             100           3 
detAvgPeakHeight             2             100           3 

destiation, the current offset, the row count and column count.


Calling loop:

      For Each trendSet In trendSets

            If InStr(ws.name, trendSet) Then
                index = findIndex(setIndex, CStr(trendSet), setSize)
                addTrend trendSet, ws, setCounter(index), 100, 3
                setCounter(index) = setCounter(index) + 1
            End If
      Next trendSet 

Also, point that it is the copy/paste function. Calling Debug.Print after the src.range.copy call does not print anything. So maybe the first copy/paste is getting hung.


src.Range(src.Cells(srcRow + 1, 1), src.Cells(srcRow + rows, col)).Copy Worksheets(dest).Range(Worksheets(dest).Cells(cRow + 1, 1), Worksheets(dest).Cells(cRow + rows, col))

Adding a column to pivot table which averages sum of the count of each month per year

I am attempting to add another column to my pivot table in which it averages the sum of the count for the months within a year and then highlights the months that have a higher count than the average.

I know that there is a way to average in the pivot table, but not in the way that I am looking, as the average that I am looking for is dependent upon the sum of count.

I have not found anyway to do this in my own, and I am not sure if there is a way to do this, without it being overly complicated.


enter image description here


Private Sub pivot()

    Dim sht             As Worksheet
    Dim pvtCache        As PivotCache
    Dim pvt             As PivotTable
    Dim StartPvt        As String
    Dim rep             As Worksheet
    Dim SrcData         As String
    Dim lstrw           As Double

    Set rep = ThisWorkbook.Worksheets("Report")

    Dim xWs As Worksheet
    Dim sheetName As String
    Application.DisplayAlerts = False
    On Error Resume Next
    Set xWs = Sheets("Pivot")
    If Err <> 0 Then
        'Do Nothing
    End If
    Application.DisplayAlerts = True

    Set sht = Sheets.Add(, rep)
    sht.Name = "Pivot"

    SrcData = rep.ListObjects("Date_Count")
    StartPvt = sht.Name & "!" & sht.Range("A3").Address(ReferenceStyle:=xlR1C1)

    Set pvtCache = ThisWorkbook.PivotCaches.Create( _
        SourceType:=xlDatabase, SourceData:=SrcData)

    Set pvt = pvtCache.CreatePivotTable( _
        TableDestination:=StartPvt, TableName:="Date_Count Pivot")

    With sht.PivotTables("Date_Count Pivot").PivotFields("Dates")
        .Orientation = xlRowField
        .Position = 1
    End With

    sht.PivotTables("Date_Count Pivot").AddDataField ActiveSheet.PivotTables( _
        "Date_Count Pivot").PivotFields("Count"), "Sum of Count", xlSum

    sht.Range("A4").Group Start:=True, End:=True, Periods:=Array(False, False, False, _
        False, True, False, True)

    lstrw = sht.Range("A1", sht.Range("A1").End(xlDown)).Rows.Count

End Sub

Subform filtering based off multiple parameters (Combobox AND Textbox)

I want to filter a subform based on two parameters on a form (combobox and textbox).

I have a Form with combobox cboTimePeriod which show data from table TimePeriod (example TimePeriod=”10.01.2018-10.02.2018”; ID=12).

Combobox data:

Data Row source= SELECT [tblTimePeriod].[TimePeriod], [tblTimePeriod].[ID] FROM tblTimePeriod ORDER BY [TimePeriod];

Data Bound Column=2 (bound to ID)

Format Column Count=1 (shows textual value of TimePeriod)
Format List Width=2,54cm

Also I have some cbobuttons with Cities, so when I press a button named “Boston”, TextBox txtCity shows i.e. “Boston”.

What I want is when ever I select time period (cboTimePeriod), result in a subform has to be filtered based on these two parameters (selected TimePeriod AND City in textbox).

And as you might guessed, it does not work.

I tried several codes, here is the one I’ve used:

How do I filter an Access subform with multiple combo boxes in the form?

And this is my implementation, which does not work:

Dim strWhere As String

 If Nz(Me.cboTimePeriod, "") <> "" Then
strWhere = strWhere & "[TimePeriodID] = '" & Trim(Me. cboTimePeriod) & " ' AND "
End If

If Nz(Me.txtSelectedCity, "") <> "" Then
    strWhere = strWhere & "[CityName] = '" & Trim(Me. txtSelectedCity) & " ' AND "
End If

If strWhere <> "" Then
    strWhere = Left(strWhere, Len(strWhere) - 5)
    Me.qry_SomeData_subform.Form.Filter = strWhere 'after this line, function exits the code        
Me.qry_ SomeData_subform.Form.FilterOn = True
    Me.qry_ SomeData_subform.Form.Filter = ""      
    Me.qry_ SomeData_subform.Form.FilterOn = False
End If

strWhere gives this:
strWhere = "[TimePreriodID] = '12 ' AND [CityName] = 'Boston '"

After aplying a filter, on a subform “Unfiltered” changes to “Filtered”, but with no change in data.

Any help is appreciated.

Inner join few columns of 2 sheets data and paste into another sheet

I’ve two excel files. In first file there is a sheet respource_master and in second file monthlydata. In Monthlydata.xls file sheet with data with sheet name mdata. The content of this mdata sheet is monthly time entries and rates of each resources. So against each resources there should 20+ rows in that sheet. In resource master sheet in first file, the sheet contains a master table of all resources, means only one row against each resource with emp_code and project name.

So what my requirement is to combine the data from the MonthlyData sheet joined with Resource master and show this combined data in a new sheet say Invoice 3

My knowledge in VBA is very less. So with experience in SQL, my question is it possible to implement it using some JOIN as follows

select R.emp_name, R.emp_code,M.hours,M.rate,R.project from
MonthlyData M inner join ResourceMaster R on R.emp_name=M.emp_name

If this is not possible how can I accomplish this combined copying between two sheets.

Lookup against double occurences, in multiple columns [on hold]

I am super new to VBA and what I have to create is way past my abilities. I need a code that would help me sort grading form results. Every name in this list occurs twice, in a random order. There is 0, 1 or maximum 2 grades per name. If there are two, they are always in separate rows. The file looks the following: Column A is an unsorted list of names, with exactly two occurrences of each name (in random rows). For each row, there is none or only one value (grade) in the range of B:AZ. The array looks something like below:

Array example screenshot

The VBA that I’m trying to write would create a new sheet in excel, that would consist of alphabetically sorted names in column A (only one instance of each name), then first grade (if exists) in column B, and second grade (if exists) in column C.

Unfortunately, because of data privacy issues I cannot share the original file.

Thanks for all your help!