Power Query - for Unique values count (currently using VBA)

[ItalianPlatinum]

Hello - currently I have VBA that will count unique values for certain criteria. my dataset is large 450k+ rows (many duplicates) and 42 columns. Problem VBA is having it is taking 15min to run the code. and looking for an alternate solution for speed efficiency.

Sub UniqueCount()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long
  Dim s As String
  Dim wsDest As Worksheet
 
  Const ResultWorkbook As String = "COMPARSION.xlsm"  '<- Edit to suit
  Const ResultWorksheet As String = "main"   '<- Edit to suit
  Const ResultTopLeft As String = "J5"          '<- Where you want the results
  Const CritColValCol As String = "3 5"         '<- Criteria column & Values column in that order. Edit to suit.
 
  With Workbooks("_ALL.xlsm").Sheets("Post Rel")
    lastrw = .Cells(.rows.count, CLng(Split(CritColValCol)(0))).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lastrw & ")"), Split(CritColValCol))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      s = "|" & a(i, 2) & "|"
      If InStr(1, d(a(i, 1)), s, 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & s
    Next i
    ReDim a(1 To d.count, 1 To 2)
    i = 0
    For Each Ky In d.Keys()
      i = i + 1
      a(i, 1) = Ky: a(i, 2) = UBound(Split(d(Ky), "||")) + 1
    Next Ky
    
  End With
  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(d.count, 2).Value = a
  End With
End Sub

 

[ItalianPlatinum]

no lonher

Hello - currently I have VBA that will count unique values for certain criteria. my dataset is large 450k+ rows (many duplicates) and 42 columns. Problem VBA is having it is taking 15min to run the code. and looking for an alternate solution for speed efficiency.

Sub UniqueCount()
  Dim d As Object
  Dim a As Variant, Ky As Variant
  Dim lastrw As Long, i As Long
  Dim s As String
  Dim wsDest As Worksheet

  Const ResultWorkbook As String = "COMPARSION.xlsm"  '<- Edit to suit
  Const ResultWorksheet As String = "main"   '<- Edit to suit
  Const ResultTopLeft As String = "J5"          '<- Where you want the results
  Const CritColValCol As String = "3 5"         '<- Criteria column & Values column in that order. Edit to suit.

  With Workbooks("_ALL.xlsm").Sheets("Post Rel")
    lastrw = .Cells(.rows.count, CLng(Split(CritColValCol)(0))).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lastrw & ")"), Split(CritColValCol))
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      s = "|" & a(i, 2) & "|"
      If InStr(1, d(a(i, 1)), s, 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & s
    Next i
    ReDim a(1 To d.count, 1 To 2)
    i = 0
    For Each Ky In d.Keys()
      i = i + 1
      a(i, 1) = Ky: a(i, 2) = UBound(Split(d(Ky), "||")) + 1
    Next Ky
   
  End With
  With Workbooks(ResultWorkbook).Sheets(ResultWorksheet).Range(ResultTopLeft)
    .Resize(, 2).Value = Array("Vs", "Trans")
    .Offset(1).Resize(d.count, 2).Value = a
  End With
End Sub

This is No longer needed