vba to extract and unique to Col B and count to Col C-CodePudding

i have data in column A with duplicates i want to extract unique values to column B from column A data and get count in column C of duplicates of column A data

here i found this vba code it's working when data is starting from Column A1 with no headers

here what is my problem i have data with headers like this below example

Col A1 Fruits    Column B1 Fruits  Column C1 Dup Count
Apple                         
Banana                     
Apple                      
Orange
Banana
Orange
Apple

i need output like this below example

Col A1 Fruits    Column B1 Fruits  Column C1 Dup Count
Apple            Apple            3  
Banana           Banana           2
Apple            Orange           2
Orange
Banana
Orange
Apple

here when i run this vba code as per my data i have getting (Run time error "9") (subscript out of range)

This line of code is highlighted in yellow color

dict(arr(i, 1)) = dict(arr(i, 1))   1

Sub uniqueValues()
   Dim sh As Worksheet, lastR As Long, arr, arrFin, i As Long, dict As Object
   
   Set sh = ActiveSheet 'use here the sheet you need
   lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
   arr = Range("A2:A" & lastR).Value
   Set dict = CreateObject("Scripting.Dictionary")
   For i = 1 To lastR
        dict(arr(i, 1)) = dict(arr(i, 1))   1
   Next i
   arrFin = Application.Transpose(Array(dict.Keys, dict.items))
   sh.Range("B2").Resize(dict.Count, 2).Value = arrFin
End Sub

CodePudding user response：

If the last row is (for example) 10, then your array arr is sized as (1 to 9, 1 to 1) so you can't use lastR as the limit in your For loop (that only works when the data starts in Row1) - use For i = 1 To UBound(arr, 1) instead.

Sub uniqueValues()
   Dim sh As Worksheet, lastR As Long, arr, arrFin, i As Long, dict As Object
   
   Set sh = ActiveSheet 'use here the sheet you need
   lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
   arr = Range("A2:A" & lastR).Value
   Set dict = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(arr, 1) '<<<< not `lastR`
        dict(arr(i, 1)) = dict(arr(i, 1))   1
   Next i
   arrFin = Application.Transpose(Array(dict.Keys, dict.items))
   sh.Range("B2").Resize(dict.Count, 2).Value = arrFin
End Sub