TigerMan

asked on

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!

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!

Last Comment

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

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

What is 'ThisFoR '?

ASKER

just another 4-digit numeric number like the others ...

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

How will the code know what 'ThisFoR' is?

In order to exclude it from the results we need to know what the value is

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.

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
```

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?

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,fieldit

Shove in UniqueList

end if

next fielditem

next counter

does that make sense and does it provide valid pseudocode?

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?

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(UniqueFo

UniqueFoRs(UBound(UniqueFo

End If

Next Counter2

Next FieldItem

Next Counter1

is this faster? better use of resources? does it work?

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?

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
```

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?

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
```

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 :)

Am only trying to be objective :)

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

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

ASKER

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

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

TRUSTED BY

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

Open in new window