Unique Worksheet Formula to VBA conversion

[BAlGaInTl]

Hello all... it's been a while since I've been on here.

I have a formula in a column that checks to see if a value in another column is unique. It puts 1 if it's the first time it's seen it, and 0 if it isn't unique. Here is the formula:

=IF(COUNTIFS($A$2:$A2,A2)=1,1,0)

That same logic is also used in other formulas to do some special math to make sure that I only count things once. Normally I could accomplish this with my pivots, but due to the nature of what we are doing, the data model method doesn't work. We also use grouping, and I can't for the life of me understand why you can't do a data model AND grouping.

So basically, I'm trying to automate the tedious task of gathering the data and then adding a bunch of formulas to calculate the fields that we need. here's a snippet of code that performs the above:

With wsMetrics
    .Cells(1, i) = "UniqSamp"
    .Cells(2, i).FormulaR1C1 = "=IF(COUNTIFS(R2C" & iSampIDCol & ":RC" & iSampIDCol & ",RC[" & iSampIDCol - i & "])=1,1,0)"
    .Cells(2, i).AutoFill Destination:=Range(.Cells(2, i), .Cells(iLastRow, i))
    .UsedRange.Value = .UsedRange.Value
End With

Where:

iSampIDCol = Column that I'm testing
i = Column where the R1C1 formula is going

There are about 8 separate calculations that I do. Some of them are more complex, but may still have that formula embeded in them. The above technically works just fine, but a month of data can be about 15K rows. So I've found that it's painfully slow from an automation standpoint.

I've tried to turn of automatic calculations and do the autofill on the last 8 calculated columns all at once, but it doesn't seem to make much of a difference.

I thought that there must be a more efficient way to get this effect in VBA.

Thoughts?

Thanks in advance.

 

[Fluff]

I'm really going to have to study up on arrays a bit more. It's really a weak point for me.

Well worth doing that, as they can be very fast.

 

[BAlGaInTl]

Well worth doing that, as they can be very fast.

This is changing my life...

I've successfully converted a couple of my formulas and the speed increase is amazing. I've left both there for now as I check to make sure that I'm getting the same results. As I step through the code, the array code takes a fraction of the time of writing formulas and copying them. I've used that process a lot before, but on smaller data sets, so it wasn't a big deal.

So the next problem... several of my formulas are INDEX MATCH, pulling data from a second query. All of the SampID in that query are unique. I import that and create a couple of named ranges LookupTempIndex and LookupTempMatch. Then I have a formula that is something like:

=INDEX(LookupTempIndex,MATCH(A2,LookupTempMatch,0),3)

Where 3 is simply the column I want to return.

It seems to me it would be possible to create two different arrays, the one I have already, and the second "temp" array. Then loop through the first to lookup values in the second, and then return a different part of the array.

So far I haven't figured it out. Is there an easier way to do this?

I'll keep researching and reading in the meantime.

 

[Fluff]

One option is

Sub GetUnique()
   Dim Ary As Variant, NAry As Variant
   Dim n As Long, j As Long, k As Long
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Ary = Sheets("Pcode").Range("A1").CurrentRegion.Resize(, 23).Value2
   NAry = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   For n = 1 To UBound(NAry)
      Dic(NAry(n, 1)) = NAry(n, 3)
   Next n
   j = 22: k = 1
   With CreateObject("scripting.dictionary")
      For n = 2 To UBound(Ary)
         If Not .Exists(Ary(n, k)) Then
            .Add Ary(n, k), Nothing
            Ary(n, j) = 1
         End If
         [COLOR=#0000ff]Ary(n, 23) = Dic(Ary(n, k))[/COLOR]
      Next n
   End With
   Sheets("Pcode").Range("A1").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
End Sub

Using a 2nd array & 2nd dictionary.
This will store the 1st & 3rd columns in Nary to Dic & the line in blue is effectively the index/match & will put the value in col 23

 

[BAlGaInTl]

@Fluff Thank you again for all of the assistance. I've updated most of my code and the difference is night and day. I will also say that I found a bug where auto calculations were being turned on by a subroutine that I was calling. Oops.

All of my formulas except for one are now done in an array using the guidlines you've given.

The last sticking point is this formula:

=PRODUCT(IF(COUNTIFS($A$2:$A2,A2,$M$2:M2,M2)=1,1,0),IF(LEFT(M2,10)="Sample Sub",1,0))

It's similar to the first unique formula that started all this, but it uses two columns to determine if something is unique.

Basically it is 1 if the ID in column A is unique AND column M starts with "Sample Sub".

I figure that there must be a way to do this as well, but so far I've failed to figure it out.

Any thoughts?

 

[Fluff]

Try something like

   Set Dic1 = CreateObject("scripting.dictionary")
   Ary = Sheets("Pcode").Range("A1").CurrentRegion.Resize(, 23).Value2
   For n = 1 To UBound(Ary)
      If Not Dic1.Exists(Ary(n, 1) & "|" & Ary(n, 13)) And Left(Ary(n, 13), 10) = "Sample Sub" Then
         Dic1.Add Ary(n, 1) & "|" & Ary(n, 13), Nothing
         Ary(n, 23) = 1
      Else
         Ary(n, 23) = 0
      End If
   Next n

 

[BAlGaInTl]

Ah, I see... so you just pipe delimited the values in Dic1 to create new "unique" values?

I'll give it a shot.

 

[BAlGaInTl]

Try something like

   Set Dic1 = CreateObject("scripting.dictionary")
   Ary = Sheets("Pcode").Range("A1").CurrentRegion.Resize(, 23).Value2
   For n = 1 To UBound(Ary)
      If Not Dic1.Exists(Ary(n, 1) & "|" & Ary(n, 13)) And Left(Ary(n, 13), 10) = "Sample Sub" Then
         Dic1.Add Ary(n, 1) & "|" & Ary(n, 13), Nothing
         Ary(n, 23) = 1
      Else
         Ary(n, 23) = 0
      End If
   Next n

This worked perfectly. I just replaced the column values with my own variables and it worked on the first shot!

1:16 for the old calculation... to short to time for the array calc.

Thanks again.

 

[Fluff]

Glad to help & thanks for the feedback