CODEWITHSUNDEEP
excelvba
user11765501
user11765501

Reputation:

issue with array duplicates

im trying to create a table with a specific type of object and number of occurrences in my data set. I tried to create 2 sets of arrays to first index the order type, and if the order type is already present in the first array add a 1 to an occurrences array. The issue i am getting is that each row is getting indexed as its own type and returning an occurrence of 1. Here is the code im using

Sub Comparison() 
Dim Sheet As Worksheet
Dim Book As Workbook
Set Book = Excel.ActiveWorkbook
Set Sheet = Book.Sheets("Sheet1")
 
Dim i As Integer
Dim c As Integer 'counter for number of items needed in array
Dim arr() As String 'type of order
Dim occ() As Long
For i = 2 To 31
If Sheet.Cells(i, 3).Value <> "" And Sheet.Cells(i, 2).Value <> "" Then
If isThere(Sheet.Cells(i, 2).Value, arr, c) = -1 Then
c = c + 1
ReDim Preserve arr(1 To c)
arr(c) = Sheet.Cells(i, 2).Value
ReDim Preserve occ(1 To c)
occ(c) = 1
Else
occ(isThere(Sheet.Cells(i, 2).Value, arr, c)) = occ(isThere(Sheet.Cells(i, 2).Value, arr, c)) + 1
End If
End If
Next i

End Sub  

 

Public Function isThere(search As String, arra As Variant, x As Integer) As Long
Dim q
isThere = -1
 
For q = 1 To x
If StrComp(search, arra(q), vbTextCompare) = 0 Then
isThere = q
Exit For
End If
Next q
End Function

Upvotes: 0

Views: 39

Answers (1)

Warcupine
Warcupine

Reputation: 4640

Instead of using two arrays you can use one dictionary.

Dictionaries have unique keys and a paired item value, the key will be your cell value, the item will be the occurance.

dim mydict as object
dim i as long
dim myval as variant

set mydict = CreateObject("Scripting.Dictionary") 'If you want to early bind add the reference to microsoft scripting runtime and set mydict to new dictionary

For i = 2 To 31
    myval = .cells(i, 3).value
    'check to see if the key exists
    if mydict.exists(myval) then
         mydict(myval) = mydict(myval) + 1
    else
         mydict.add myval, 1
    end if
next i

Upvotes: 1

Related Questions