Creating dictionaries and sending e-mails

[Demirion]

Hi. I have a macro whose task is to create dictionaries, based on the dictionary keys filter data and send e-mails. Unfortunately, there are three bugs that I can't fix.
Now I paste sheets from the macro file with sample data:

macro mail.xlsm
	A	B	C	D	E
1	Subject and Mail body		Error cateogry to filter	Error cateogry	Resolution
2	topic
3	Dear User,<br><br> dfeghfdhdfhfd
4	<br><br> kihjsfgikolsdhflkjhsdf		Center is blocked	Center is blocked	gfjhgfjgfhjhgjghfjfghjhg
5			Quantity Exceeded	Quantity Exceeded	hgfjhfgjfhgjfjhgfgfhjhg
Errors

macro mail.xlsm
	A	B
1	to
2	cc
3	bcc
4	subject
5	body1
6	body2
Mail

macro mail.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	1	2	Country	3	4	5	6	7	8	user	Error Category
2
3
4
5
Work

macro mail.xlsm
	A	B
1	Error cateogry	Resolution
2
3
ResolToSend

Here is a spreadsheet from a batch file:

example.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	1	2	country	4	5	6	7	8	9	users	error category
2	aaa	aaa	austria	aaa	aaa	aaa	aaa	aaa	aaa	mark jones (mark.jones@gmail.com)	quantity exceeded
3	aaa	aaa	france	aaa	aaa	aaa	aaa	aaa	aaa	arnold henderson (arnold.henderson@gmail.com)	quantity exceeded
4	aaa	aaa	spain	aaa	aaa	aaa	aaa	aaa	aaa	joe big (joe.big@gmail.com)	center is blocked
5	aaa	aaa	germany	aaa	aaa	aaa	aaa	aaa	aaa	jack snow (jack.snow@gmail.com)	quantity exceeded
6	aaa	aaa	england	aaa	aaa	aaa	aaa	aaa	aaa	maria brown (maria.brown@gmail.com)	center is blocked
data

Here is the code for the entire macro:

Dim vFile As Variant
    Dim wsInput1 As Worksheet
    Dim wbTrack As Workbook
    Dim lRow As Long
    Dim rRangeC As Range
    Dim rCellC As Range
    Dim oCountryDict As New Dictionary
    Dim oHolderDict As New Dictionary
    Dim vCountry As Variant
    Dim rRange As Range
    Dim rCell As Range
    Dim vHolder As Variant
    Dim rRangeE As Range
    Dim rCellE As Range
    Dim oErrorDict As New Dictionary
    Dim iLastRowE As Integer
    Dim s As String

    

    vFile = Application.GetOpenFilename(FileFilter:="Excel files (*.xls*), *.xls*", _
    Title:="Select tracker", MultiSelect:=False)
         
    On Error Resume Next
        If vFile = "False" Then
            MsgBox "Cannot find tracker file. Closing Macro."
            Exit Sub
        End If
    On Error GoTo 0
    
    Set wbTrack = Application.Workbooks.Open(vFile)
    On Error Resume Next
    Set wsInput1 = wbTrack.Worksheets("data")
    On Error GoTo 0
    
    
    With wsInput1
        .AutoFilterMode = False
        .Range("A1").AutoFilter
        
        lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
    
        Set rRangeC = .Range(.Cells(2, 3), .Cells(lRow, 3)).SpecialCells(xlCellTypeVisible)
        For Each rCellC In rRangeC
            If Not oCountryDict.Exists(rCellC.Value) Then
                oCountryDict.Add rCellC.Value, rCellC.Row
            End If
        Next rCellC
    
        'for each unique country
        For Each vCountry In oCountryDict.Keys
            On Error Resume Next
            .ShowAllData
            On Error GoTo -1
            'autoFilter on column with this country
            .UsedRange("A1").AutoFilter Field:=3, Criteria1:=vCountry
            
            'creating dict for all unique holders
            Set rRange = .Range(.Cells(2, 10), .Cells(lRow, 10)).SpecialCells(xlCellTypeVisible)
            
            
            For Each rCell In rRange
                If Not oHolderDict.Exists(rCell.Value) Then
                    oHolderDict.Add rCell.Value, rCell.Row
                End If
            Next rCell
            
            'for each unique holder
            For Each vHolder In oHolderDict.Keys
            'autofilter on column with this holder
            .UsedRange.AutoFilter Field:=10, Criteria1:=vHolder
            wsMail.Cells(1, 2).Value = oHolderDict(vHolder)
            'copy and pasting filtered data from tracker
            .Range(.Cells(2, 1), .Cells(lRow, 11)).SpecialCells(xlCellTypeVisible).Copy
            wsWork.Cells(2, 1).PasteSpecial
            'creating dict for holders error
            Set rRangeE = .Range(.Cells(2, 11), .Cells(lRow, 11)).SpecialCells(xlCellTypeVisible)
                For Each rCellE In rRangeE
                    If Not oErrorDict.Exists(rCellE.Value) Then
                        oErrorDict.Add rCellE.Value, rCellE.Row
                    End If
                Next rCellE
                
            With wsErrors
                .Cells(2, 1).Copy wsMail.Cells(4, 2)
                .Cells(3, 1).Copy wsMail.Cells(5, 2)
                .Cells(4, 1).Copy wsMail.Cells(6, 2)
 
                'filtering errors table using dict keys with errors
                .Range("A1:E1").AutoFilter Field:=3, Criteria1:=oErrorDict.Keys, Operator:=xlFilterValues
                'last row after filtering errors
                iLastRowE = .Cells(.Rows.Count, 3).End(xlUp).Row
                'copy/paste filtered resolution to ResoltToSend sheet
                .Range(.Cells(1, 4), .Cells(iLastRowE, 5)).SpecialCells(xlCellTypeVisible).Copy
                wsResol.Cells(1, 1).PasteSpecial
            End With
            
            'Call MailForDict
            
            .ShowAllData
            wsWork.Rows("2:" & wsWork.Rows.Count).Clear
            
           Next vHolder
        Next vCountry
    End With

The first error concerns pasting e-mails to the Work sheet. Instead of e-mails, numbers are stuck. For example, if macro paste the first e-mail, "1" appears, if paste the second e-mail, "2" etc. The first problem is that in this code snippet:

For Each rCell In rRange
                If Not oHolderDict.Exists(rCell.Value) Then
                    oHolderDict.Add rCell.Value, rCell.Row
                End If
            Next rCell
            
            'for each unique holder
            For Each vHolder In oHolderDict.Keys
            'autofilter on column with this holder
            .UsedRange.AutoFilter Field:=10, Criteria1:=vHolder
            wsMail.Cells(1, 2).Value = oHolderDict(vHolder)

Second problem is that filtering by oErrorDict dictionary keys is not working in the Errors sheet:

For Each rCellE In rRangeE
                 If Not oErrorDict.Exists(rCellE.Value) Then
                      oErrorDict.Add rCellE.Value, rCellE.Row
                 End If
Next rCellE
             
      .Range("A1:E1").AutoFilter Field:=3, Criteria1:=oErrorDict.Keys, Operator:=xlFilterValues

Last problem is that the whole loop after traversing all the oCountryDict and oHolderDict dictionary keys does not stop and runs on empty emails and I have to disable the process.

Maybe someone will be able to help me?

 

[Demirion]

To sum up the first problem with incorrect email filtering is solved when I change this code:

wsMail.Cells(1, 2).Value = oHolderDict(vHolder)

to this code:

wsMail.Cells(1, 2).Value = vHolder

I managed to solve the second problem with filtering errors. I removed the blank column and moved the cells. Unfortunately, there is another problem because the filters are stacking and I would like only the last one to be visible. How can this be done?

                '
'filtering errors table using dict keys with errors
.Range("A1").AutoFilter Field:=2, Criteria1:=oErrorDict.Keys, Operator:=xlFilterValues
'last row after filtering errors
iLastRowE = .Cells(.Rows.Count, 2).End(xlUp).Row
'copy/paste filtered resolution to ResoltToSend sheet
.Range(.Cells(1, 3), .Cells(iLastRowE, 4)).SpecialCells(xlCellTypeVisible).Copy
 wsResol.Cells(1, 1).PasteSpecial