Macro VBA: counting occurances in column - percentage

[tuspilica]

Hello friends,

I'm working with a database full of records. Most of them are duplicated.

The code is importing a excel file.
Arrange the data by column A. Replace data in column C. Converts time format. Add a new sheet.
Also, it counts the records in column A and put the occurances in Sheet2.

After these operations, i want to remove/delete all the duplicated rows based on columns A&B.
It is working well if i put it before counting the occurances, but then, when the occurances are counted, they are counted only once.
I puted this line at the end, to delete the duplicated rows, after the occurances in column A are counted.

How to integrate this line so to remove the duplicated rows, after they are counted?

Range("A:B").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

How can be measured also the percentage of occurance per each name, and to be displayed in column 3, Sheet2?
Do i need to add another sheet if i want to count also the values from column B?

The Excel file i share it on Microsoft OneDrive:
https://1drv.ms/x/s!AhRc3CwuYwGwc3rUqQXtydvvC_Q

Thank you

Sub import()


Dim OpenFileName As String
Dim wb As Workbook
'Select and open workbook
OpenFileName = Application.GetOpenFilename("import data,*.xlsx")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)


MsgBox ("Done")


'Sort imported data by column A
Range("A1:G4000").Sort Key1:=Range("A1"), Header:=xlYes


'Replace values from column C - Feedback with appropriate values
Range("C:C").Replace What:="1", Replacement:="Great", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Range("C:C").Replace What:="2", Replacement:="Love", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Range("C:C").Replace What:="3", Replacement:="Like", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Range("C:C").Replace What:="4", Replacement:="Nice", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Range("C:C").Replace What:="5", Replacement:="OKKK", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Range("C:C").Replace What:="6", Replacement:="Hmmm", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False


'Convert time format
Columns("D:E").NumberFormat = "mmmm dd, yyyy hh:mm:ss AM/PM"


'Add new sheet
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)


'Start to count the occurances in column A
    Dim sourceRange As Range
    Dim sourceMem As Object
    Dim curRow As Integer


    With Worksheets("Sheet1")
        Set sourceRange = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).row)
    End With


    Set sourceMem = CreateObject("Scripting.dictionary")


    For Each cell In sourceRange
        On Error GoTo ERREUR
        sourceMem.Add cell.Value, 1
        On Error GoTo 0
    Next


    curRow = 2


'Place on Sheet2 the Names of the tourists and number of occurances
    With Worksheets("Sheet2")
        .Range("A1").Value = "Tourist Name"
        .Range("B1").Value = "Occurances"
        For Each K In sourceMem.Keys
            .Range("A" & curRow).Value = K
            .Range("B" & curRow).Value = sourceMem(K)
            curRow = curRow + 1
        Next K
                Range("A1:D4000").Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlYes
    End With


    Set sourceMem = Nothing
    Exit Sub


ERREUR:
    sourceMem(cell.Value) = sourceMem(cell.Value) + 1
    Resume Next
    
'Remove duplicates - here the code should return to Sheet1 and remove the duplicates after the occurances are counted in Sheet2
Range("A:B").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes


End Sub