Avatar of TigerMan
TigerManFlag for Australia

asked on 

Excel 2003 - Comparing Arrays

Hi

I have FoRArtsArr with n records by 20 columns.  In columns 10, 13, and 16 there can be only one of 157 possible values (these values are always 4-character numeric i.e. 0102, 0906, 1407, etc).

I wish to create a new single column array (RelatedFoRsArr) that contains a unique list of the values in column 10, 13, and 16 of FoRArtsArr except ThisFoR (to be tested in the main routine, not as an afterthought).  RelatedFoRsArr should have only as many rows as there are unique values from FoRArtsArr.

Please avoid geek-speak-coding i.e. proper variable names and structured routines so I can understand and modify as needed.

I am not able to check in every day so please anticipate delays in my replying … thanks in advance!
Microsoft Excel

Avatar of undefined
Last Comment
TigerMan
Avatar of TinTombStone
TinTombStone

This code worked for me.  I'm sure this could be improved, but it is a start

It first sorts your array by the required column
then picks out each unique value from the column and drops it into a collection
Repeats for the other columns
then loads the values from the collection in your new array and sorts them

Dim colUniqueVals As Collection



Sub GetUniqueArrayVals()
Dim FoRArtstempArr() As Variant
Dim RelatedFoRstempArr()

    'This just created a temp tempArray for my practice
    FoRArtstempArr() = Range("A1:S33")
    
    'initialise new arrCollection to store unique values later
    Set colUniqueVals = New Collection

    'sort  FoRArtstempArr by Column 10
    SortArray FoRArtstempArr, 10
    'load unique values from Column 10 into a Collection
    LoadUniqueValues FoRArtstempArr, 10
    
    'repeat for Column 13 and 16
    SortArray FoRArtstempArr, 13
    LoadUniqueValues FoRArtstempArr, 13
    
    SortArray FoRArtstempArr, 16
    LoadUniqueValues FoRArtstempArr, 16
    
    'redim to size of arrCollection
    ReDim RelatedFoRstempArr(1 To colUniqueVals.Count)
    
    'load arrCollection values into RelatedFoRstempArr
    For i = 1 To colUniqueVals.Count
        RelatedFoRstempArr(i) = colUniqueVals(i)
    Next i
    
    'sort RelatedFoRstempArr
    SortArray RelatedFoRstempArr


End Sub



Sub SortArray(ByRef tempArr, Optional arrCol As Integer)
'procedure to sort arrColumn of tempArray
Dim arrRow As Long
Dim tempVal As Variant
    If Not arrCol = 0 Then
        For arrRow = 1 To UBound(tempArr, 1) - 1
            If tempArr(arrRow, arrCol) > tempArr(arrRow + 1, arrCol) Then
                tempVal = tempArr(arrRow, arrCol)
                tempArr(arrRow, arrCol) = tempArr(arrRow + 1, arrCol)
                tempArr(arrRow + 1, arrCol) = tempVal
                SortArray tempArr, arrCol
            End If
        Next
    Else
        For arrRow = 1 To UBound(tempArr, 1) - 1
            If tempArr(arrRow) > tempArr(arrRow + 1) Then
                tempVal = tempArr(arrRow)
                tempArr(arrRow) = tempArr(arrRow + 1)
                tempArr(arrRow + 1) = tempVal
                SortArray tempArr
            End If
        Next
    End If

End Sub


Sub LoadUniqueValues(ByRef tempArr, arrCol As Integer)
'procedure to load unique values into a arrCollection
Dim arrRow As Long
Dim uCount As Long
On Error Resume Next
    For arrRow = 1 To UBound(tempArr, 1)
        If tempArr(arrRow, arrCol) <> tempArr(arrRow + 1, arrCol) Then
            colUniqueVals.Add tempArr(arrRow, arrCol)
        End If
    Next
End Sub

Open in new window

Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

hi tts,

that looks like its on the right track ... just one thing ... I don't see this requirement coded into that module:

"except ThisFoR (to be tested in the main routine, not as an afterthought)."

is it there? if yes, please point me to it ... if no, can you add in please?

nb: it is important that this ie included in the LoadUniqueValues sub
Avatar of TinTombStone
TinTombStone

What is 'ThisFoR '?
Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

just another 4-digit numeric number like the others ...
Avatar of TinTombStone
TinTombStone

OK.

How will the code know what 'ThisFoR' is?

In order to exclude it from the results we need to know what the value is
ASKER CERTIFIED SOLUTION
Avatar of TinTombStone
TinTombStone

Blurred text
THIS SOLUTION IS ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
Avatar of TinTombStone
TinTombStone

Sorry again, this
Dim colUniqueVals As Collection
Dim THisFoR As Long


Sub GetUniqueArrayVals()
Dim FoRArtstempArr() As Variant
Dim RelatedFoRstempArr()

Dim itm As Long

THisFoR = 99999

    'This just created a temp tempArray for my practice
    FoRArtstempArr() = Range("A1:S31")
    
    'initialise new arrCollection to store unique values later
    Set colUniqueVals = New Collection

    'sort  FoRArtstempArr by Column 10
    SortArray FoRArtstempArr, 10
    'load unique values from Column 10 into a Collection
    LoadUniqueValues FoRArtstempArr, 10
    
    'repeat for Column 13 and 16
    SortArray FoRArtstempArr, 13
    LoadUniqueValues FoRArtstempArr, 13
    
    SortArray FoRArtstempArr, 16
    LoadUniqueValues FoRArtstempArr, 16
    
    'redim to size of arrCollection
    ReDim RelatedFoRstempArr(1 To colUniqueVals.Count)
    
    'load arrCollection values into RelatedFoRstempArr
    For i = 1 To colUniqueVals.Count
        RelatedFoRstempArr(i) = colUniqueVals(i)
    Next i
    
    'sort RelatedFoRstempArr
    SortArray RelatedFoRstempArr

    

End Sub



Sub SortArray(ByRef tempArr, Optional arrCol As Integer)
'procedure to sort arrColumn of tempArray
Dim arrRow As Long
Dim tempVal As Variant
    If Not arrCol = 0 Then
        For arrRow = 1 To UBound(tempArr, 1) - 1
            If tempArr(arrRow, arrCol) > tempArr(arrRow + 1, arrCol) Then
                tempVal = tempArr(arrRow, arrCol)
                tempArr(arrRow, arrCol) = tempArr(arrRow + 1, arrCol)
                tempArr(arrRow + 1, arrCol) = tempVal
                SortArray tempArr, arrCol
            End If
        Next
    Else
        For arrRow = 1 To UBound(tempArr, 1) - 1
            If tempArr(arrRow) > tempArr(arrRow + 1) Then
                tempVal = tempArr(arrRow)
                tempArr(arrRow) = tempArr(arrRow + 1)
                tempArr(arrRow + 1) = tempVal
                SortArray tempArr
            End If
        Next
    End If

End Sub


Sub LoadUniqueValues(ByRef tempArr, arrCol As Integer)
'procedure to load unique values into a arrCollection
Dim arrRow As Long
Dim uCount As Long
On Error Resume Next
    For arrRow = 1 To UBound(tempArr, 1)
        If tempArr(arrRow, arrCol) <> tempArr(arrRow + 1, arrCol) And tempArr(arrRow, arrCol) <> THisFoR Then
            colUniqueVals.Add tempArr(arrRow, arrCol)
        End If
    Next
End Sub

Open in new window

Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

lol ... yes, ThisFoR is a variable.
thanks so far ... i didn't mention the number of records and i think that is a stumbling block to sorting routines
I have played with the above somewhat.  It is returning out of stack space and a few issues.
I also have a sample of data to run this over (currently 11,700 records, but will grow to about 25000 later) and therefore UBound(tempArr, 1) (in For arrRow = 1 To UBound(tempArr, 1)) is quite large.  I suspect this is why the stack space problem?  I wonder if walkenbach's counting sort would do this volume better?
that said, i am not sure there is a need to sort ArtsArr? here is my uninformed thinking

dim UniqueList
for counter = 1 to ubound(FoRArtsArr, 1)
for each fielditem(10, 13, 16)
if FoRArtsArr(counter,fielditem) <> ThisFoR and FoRArtsArr(counter,fielditem) not in UniqueList then
Shove in UniqueList
end if
next fielditem
next counter

does that make sense and does it provide valid pseudocode?
Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

here is better pseudocode for what i was thinking

Dim UniqueFoRs, Counter1, Counter2, Test
For Counter1 = 1 To UBound(ArtsArr, 1)
    For Each FieldItem In Array(10, 13, 16)
        Test = ArtsArr(Counter1, FieldItem)
        For Counter2 = 1 To UBound(UniqueFoRs, 1)
            If UniqueFoRs(Counter2) <> Test Then
                ReDim UniqueFoRs(UBound(UniqueFoRs) + 1, 1)
                UniqueFoRs(UBound(UniqueFoRs, 1)) = Test
            End If
        Next Counter2
    Next FieldItem
Next Counter1

is this faster? better use of resources?  does it work?
Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

And here is code that works to achieve the desired outcome ... runs in about 2 seconds over 11,000 records

a couple of questions
1: can this be made more efficient?
2: can you give the vb to transpose UniqueFoRs?


Dim UniqueFoRs(), ArtCounter, UniqueCounter, Test, NumRecs, AddRec
ReDim UniqueFoRs(1, 1)
NumRecs = 1
AddRec = True
For ArtCounter = 1 To UBound(ArtsArr, 1)
    For Each FieldItem In Array(10, 13, 16)
        Test = ArtsArr(ArtCounter, FieldItem)
        If Test <> "" And Test <> ThisFoR Then
            For UniqueCounter = 1 To UBound(UniqueFoRs, 2)
                If UniqueFoRs(1, UniqueCounter) = Test Then
                    AddRec = False
                End If
            Next UniqueCounter
            If AddRec Then
                UniqueFoRs(1, NumRecs) = Test
                NumRecs = NumRecs + 1
                ReDim Preserve UniqueFoRs(1, NumRecs) ' need to transpose
            End If
        End If
        AddRec = True
    Next FieldItem
Next ArtCounter

Open in new window

Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

OK, I have completed this one and all specs are met.
It was working through your models that gave me the impetus to seek different ways to resolve this algorithm; you have also put considerable effort into assisting.  Therefore I will give you points but will modify downwards for incomplete answer.
I hope this is cool for you?
' assemble unique FoRs from FoRArts into UniqueFoRs

Dim UniqueFoRs(), FoRArtCounter, UniqueCounter, Test, NumRecs, AddRec, tempArr
ReDim UniqueFoRs(1, 1)
NumRecs = 1     'tracks number of rows in UniqueFoRs
AddRec = True   'discriminates whether to add new row to UniqueFoRs
For FoRArtCounter = 1 To UBound(FoRArts, 1) 'FoRArts is list of arts related to ThisFoR
    For Each FieldItem In Array(10, 13, 16)
        Test = FoRArts(FoRArtCounter, FieldItem)
        If Test <> "" And Test <> ThisFoR Then  'caters for blanks and matches with ThisFoR
            For UniqueCounter = 1 To UBound(UniqueFoRs, 2) 'cycle thru UniqueFoRs
                If UniqueFoRs(1, UniqueCounter) = Test Then
                    AddRec = False  'if FoR exists then don't add new record
                End If
            Next UniqueCounter
            If AddRec Then
                UniqueFoRs(1, NumRecs) = Test   'add the record
                NumRecs = NumRecs + 1           'increment row count in UniqueFoRs
                ReDim Preserve UniqueFoRs(1, NumRecs) ' need to transpose
            End If
        End If
        AddRec = True
    Next FieldItem
Next FoRArtCounter
ReDim Preserve UniqueFoRs(1, UBound(UniqueFoRs, 2) - 1)
tempArr = Application.Transpose(UniqueFoRs)
UniqueFoRs = tempArr

Open in new window

Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

I don't know if these ratings can be changed after posting, but if you are not happy with this please let me know.
Am only trying to be objective :)
Avatar of TinTombStone
TinTombStone

Hi TigerMan

Sorry been at work for a day.  Thats great, I'm going to have a look at your solution tomorrow, I'm sure it will help me too.

I thought you may have a problem with stack overflow on the sort and going to try and correct it.  

Glad to have been of a little help, I'm sure your code will teach me a lot to

TTT
Avatar of TigerMan
TigerMan
Flag of Australia image

ASKER

Is cool ... I will have several more questions yet so you can dive in again as you wish :)
Microsoft Excel
Microsoft Excel

Microsoft Excel topics include formulas, formatting, VBA macros and user-defined functions, and everything else related to the spreadsheet user interface, including error messages.

144K
Questions
--
Followers
--
Top Experts
Get a personalized solution from industry experts
Ask the experts
Read over 600 more reviews

TRUSTED BY

IBM logoIntel logoMicrosoft logoUbisoft logoSAP logo
Qualcomm logoCitrix Systems logoWorkday logoErnst & Young logo
High performer badgeUsers love us badge
LinkedIn logoFacebook logoX logoInstagram logoTikTok logoYouTube logo