Sort an array by selecting the occurances vba - arrays

I am currently writing a macro for Solidworks using VBA. This macro sets an array with the x, y, and arctan locations of a note. I am then looking to sort array using a bubblesort method. The array is a single dimensional array and it first sets the x values, then the y and then the arctan. If there are 9 notes then 0-8 is the x values, 9-17 are the y values, and 18-26 are the arctan. This is where I am running into an issue. I need to select the range that the sort uses.
arrlen = arrlen - 1
ReDim Preserve vloc(arrlen - 1)
BubbleSort1 vloc
arrlen1 = arrlen1 - 1
ReDim Preserve vloc(arrlen To arrlen1)
BubbleSort1 vloc
Above is my code where I call up the sorts. arrlen and arrlen1 are counters for the total notes for each value.
I am getting a script out of range error on the second sort call out.
I am not against rewriting both the initial setting of the array and the sort to us a multidimensional array, but I just don't know how to properly do that.
Below is the code where I set the array.
Set swFirstNote = swView.GetFirstNote
Set swNote = swView.GetFirstNote
ReDim notes(notesTotalCounter)
ReDim vloc(notesTotalCounter)
i = 0
arrlen = 0
While Not swNote Is Nothing
If swNote.GetText Like "`*" Then
Set swAnno = swNote.GetAnnotation
loc = swAnno.GetPosition
Dim t As Double
Dim x As Double
Dim y As Double
x = loc(0)
y = loc(1)
t = ArcTan2(cpX - loc(0), cpY - loc(1))
vloc(i) = x
i = i + 1
arrlen = arrlen + 1
End If
Set swNote = swNote.GetNext
Wend
Set swFirstNote = swView.GetFirstNote
Set swNote = swView.GetFirstNote
ReDim Preserve vloc(notesTotalCounter)
i = arrlen
arrlen1 = arrlen
While Not swNote Is Nothing
If swNote.GetText Like "`*" Then
Set swAnno = swNote.GetAnnotation
ReDim Preserve vloc(i)
loc = swAnno.GetPosition
x = loc(0)
y = loc(1)
t = ArcTan2(cpX - loc(0), cpY - loc(1))
vloc(i) = y
i = i + 1
arrlen1 = arrlen1 + 1
End If
Set swNote = swNote.GetNext
Wend
Any help would be greatly appreciated.

Here is something that I wrote recently to sort an array of training subjects into alphabetical order. After returning from this subroutine, I load the array into a combo box. The training subjects are listed in a priority order in a row of a worksheet, from cell C2 and to the left. The number of training subjects varies as it can be added to and deleted at various times. Here is the subroutine that gets called to create the global array strSubject() to pass to the Userform Activate event to populate the combo box.
You should be able to take the basic idea behind the sorting routine and adapt it for your code. Because all of my records are text, I use the tilde (~) to ensure the second array gets populated with the next available record alphabetically. As you are using numbers, you may want to replace the tilde in thie code with a number that is less than any possible value in your data, so if your lowest value is 1, make the comparator -1. If your lowest possible value is -i,ooo,ooo,ooo, make your comparator lower than that. If you are unsure, run a third routine to find the lowest value in your data array, subtract 1 and make that value your comparator value.
Sub Create_Alphabetical_Subject_List()
Dim f As Integer
Dim x As Integer: x = 1
Dim y As Integer: y = 1
Dim strTempSubject() As String
Set wss = ThisWorkbook.Sheets("Internal Training Matrix")
varSubjectCount = WorksheetFunction.CountA(Worksheets("Internal Training Matrix").Range("C2", Worksheets("Internal Training Matrix").Range("C2").End(xlEnd)))
ReDim varSortedFlag(varSubjectCount)
ReDim varSorted(varSubjectCount)
ReDim strTempSubject(varSubjectCount)
ReDim strSubject(varSubjectCount)
For x = 1 To varSubjectCount
If wss.Cells.Item(2, x + 2) <> "" And wss.Cells.Item(2, x + 2) <> "Spare" Then
strTempSubject(x) = wss.Cells.Item(2, x + 2) ' From row 2 col 3 initially
varSorted(x) = "~"
varSortedFlag(x) = ""
End If
Next x
For y = 1 To varSubjectCount
For x = 1 To varSubjectCount
If varSortedFlag(x) = "" And strTempSubject(x) < varSorted(y) Then
varSorted(y) = strTempSubject(x) ' Swap out a lower value
f = x ' Track which record was last copied to new array
End If
Next x
strSubject(y) = varSorted(y)
varSortedFlag(f) = "Done" ' Remove the record from future comparrisons
Next y
End Sub

Related

VBA Take specific values from one array into another array dynamically

I have an array with over 130 elements, out of those elements I only want specific elements. Those elements I have been able to specify with an if statement and an Instr function. However, I am stuck when figuring out how to those values from main array into a different array. The issue is that I don't know how many values will actually fit the requirements and so the second array I can't define before the values are counted.
How would I transfer certain values that fit the Instr function from one array to the other array.
Current code -
For v = 0 To UBound(NViews)
ViewNames = NViews(v)
If InStr(ViewNames, "Triage Folder") Then
ReDim TriageNames(0 To p)
TriageNames(p) = NViews(v)
p = p + 1
End If
Next
Updated Code**
p = 1
ReDim TriageNames(0 To p)
For v = 0 To UBound(NViews)
ViewNames = NViews(v)
If InStr(ViewNames, "Triage Folder") Then
TriageNames(p) = NViews(v)
p = p + 1
ReDim Preserve TriageNames(0 To p)
End If
Next
Make TriageNames the same size as NViews, then use ReDim Preserve, after you populated TriageNames completely:
Dim TriageNames As Variant
ReDim TriageNames(0 to Ubound(NViews))
For v = 0 To Ubound(NViews)
If InStr(NViews(v), "Triage Folder") > 0 Then
Dim p As Long
TriageNames(p) = NViews(v)
p = p + 1
End If
Next
If p > 0 Then
ReDim Preserve TriageNames(0 to p - 1)
End If

Excel VBA - Determining Column or Row Target of Array UDF

I have a simple excel UDF for converting an array of mass values to mol fractions. Most times, the output will be a column array (n rows by 1 column).
How, from within the VBA environment, do I determine the dimensions of the target cells on the worksheet to ensure that it should be returned as n rows by 1 column versus n columns by 1 row?
Function molPct(chemsAndMassPctsRng As Range)
Dim chemsRng As Range
Dim massPctsRng As Range
Dim molarMasses()
Dim molPcts()
Set chemsRng = chemsAndMassPctsRng.Columns(1)
Set massPctsRng = chemsAndMassPctsRng.Columns(2)
chems = oneDimArrayZeroBasedFromRange(chemsRng)
massPcts = oneDimArrayZeroBasedFromRange(massPctsRng)
'oneDimArrayZeroBasedFromRange is a UDF to return a zero-based array from a range.
ReDim molarMasses(UBound(chems))
ReDim molPcts(UBound(chems))
totMolarMass = 0
For chemNo = LBound(chems) To UBound(chems)
molarMasses(chemNo) = massPcts(chemNo) / mw(chems(chemNo))
totMolarMass = totMolarMass + molarMasses(chemNo)
Next chemNo
For chemNo = LBound(chems) To UBound(chems)
molPcts(chemNo) = Round(molarMasses(chemNo) / totMolarMass, 2)
Next chemNo
molPct = Application.WorksheetFunction.Transpose(molPcts)
End Function
I understand that, if nothing else, I could have an input parameter to flag if return should be as a row array. I'm hoping to not go that route.
Here is a small example of a UDF() that:
accepts a variable number of input ranges
extracts the unique values in those ranges
creates a suitable output array (column,row, or block)
dumps the unique values to the area
Public Function ExtractUniques(ParamArray Rng()) As Variant
Dim i As Long, r As Range, c As Collection, OutPut
Dim rr As Range, k As Long, j As Long
Set c = New Collection
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' First grab all the data and make a Collection of uniques
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For i = LBound(Rng) To UBound(Rng)
Set r = Rng(i)
For Each rr In r
c.Add rr.Value, CStr(rr.Value)
Next rr
Next i
On Error GoTo 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' next create an output array the same size and shape
' as the worksheet output area
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
k = 1
With Application.Caller
ReDim OutPut(1 To .Rows.Count, 1 To .Columns.Count)
End With
For i = LBound(OutPut, 1) To UBound(OutPut, 1)
For j = LBound(OutPut, 2) To UBound(OutPut, 2)
If k < c.Count + 1 Then
OutPut(i, j) = c.Item(k)
k = k + 1
Else
OutPut(i, j) = ""
End If
Next j
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' put the data on the sheet
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ExtractUniques = OutPut
End Function
You should return two dimensional arrays: n × 1 for row and 1 × n for column vectors.
So you need either
Redim molPcts(1, Ubound(chems) + 1)
or
Redim molPcts(Ubound(chems) + 1, 1)
To refer to them, you need to use both indices:
molPcts(1, chemNo + 1)
or
molPcts(chemNo + 1, 1)
If you prefer 0-based arrays, the redim should be like this:
Redim molPcts(0 To 0, 0 To Ubound(chems))
Redim molPcts(0 To Ubound(chems), 0 To 0)

Return label and value based on order in Excel

Suppose I have a two column array in excel where the first column is text and the second column is numbers. I would like to have a command that would return an array sorted according to the values in the second column. I don't want to use the custom sort command because I would like to be able to update the numerical values in the second column and automatically have the sorted array updated.
The only other way of sorting automatically is by programming... MACROs.
You can either create a button and assign the macro to that button
OR
You put it in a selection change event which runs your macro every time a cell has changed.
up to you.
In the following code I did it for a button:
Sub btnSort()
Dim swapped As Boolean ' Boolean value to check if the values have been swapped
Dim boolEmpty As Boolean ' Boolean value to check if the cell value is empty
Dim tmp1, tmp2 As Variant ' Temporary variable,which holds temporary value
Dim numRows As Integer ' Number of NON-EMPTY rows
Dim tempArray1 As Variant ' Holds values in column 1 with certain values
Dim tempArray2 As Variant ' Holds values in column 2 with numerica values
boolEmpty = False 'Give initial value to variable; Assuming that the first checked cell is NOT EMPTY
'Count the number of cells with actual values in them
numRows = 0
ctr = 1
Do While (boolEmpty <> True)
'If the cell value contains something then increment variable numRows
If Sheet6.Cells(ctr, 1).Value > 0 Then
numRows = numRows + 1
boolEmpty = False
ctr = ctr + 1
Else
'if true then exit while loop
boolEmpty = True
End If
Loop
ReDim tempArray1(numRows) ' Re-dimensionalize the array with the appropriate size
ReDim tempArray2(numRows) ' Re-dimensionalize the array with the appropriate size
'Fill tempArray1 & 2 with values
For i = 0 To numRows - 1
tempArray1(i) = Sheet6.Cells(i + 1, 1).Value
tempArray2(i) = Sheet6.Cells(i + 1, 2).Value
Next i
'Set variables
swapped = True
ctr = 0
'If swapped remains TRUE then continue sorting the array
Do While (swapped)
swapped = False
ctr = ctr + 1
'BUBBLE SORT
'Check if next element in array is bigger than the first one.
'If TRUE then swap the elements
'If FALSE then continue until looking through teh array until done.
For i = 0 To numRows - ctr
If tempArray2(i) > tempArray2(i + 1) Then
tmp1 = tempArray1(i)
tmp2 = tempArray2(i)
tempArray1(i) = tempArray1(i + 1)
tempArray2(i) = tempArray2(i + 1)
tempArray1(i + 1) = tmp1
tempArray2(i + 1) = tmp2
swapped = True
End If
Next i
Loop
'Redisplay the sorted array in excel sheet
For i = 0 To UBound(tempArray2)
Sheet6.Cells(i + 1, 1).Value = tempArray1(i)
Sheet6.Cells(i + 1, 2).Value = tempArray2(i)
Next i
End Sub
The reason I did it for a button is because if you do it the selection change event way your excel is constantly going to refresh every time you change a cell. BUT, there is a work around for this.
In the example above I used bubble sort, you can find many examples on how to understand it online somewhere.
if you want my code to work you will have to change my sheet6.cells(....
to
your sheet number, depending where your list is found in your workbook.
In the "Count the number of cells with actual values..."
You will have to change ...Cells(ctr,1) to the row and column index where your list is found.
Hope I didn't confuse you.
Here is the other way I was talking about earlier:
'If value has changed in column 2 then run macro
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 1 And Target.Column < 3 Then
MsgBox Target.Column
End If
End Sub
This code needs to be in the same sheet. It checks to see if the value that you changed is in fact within column 2 ( Target.Column > 1 And Target.Column < 3 ) You can go a step further and add Target.row < 10 (which means, the cell that was modified is column 2 and less than row 10)
where you see msgbox is where you will copy and paste the code "bubble sort and etc.." in.
Hope this helps.

Removing duplicates of a 2D array in VBA

I have found lots of methods to remove duplicates of a 1D array but could not find a 2D example.
In addition to that, I wonder if the fuction can "leave" an instance of the duplicate item instead of removing them all.
Is it possible to do it?
Example:
Sub Tests()
Dim Example()
Example(0,0) = "Apple"
Example(1,0) = "Apple"
Example(0,1) = "Pear"
Example(1,1) = "Orange"
End Sub
Remaining items would be: Apple, Pear and Orange
This is how I like to do it, using a separate array to hold the unique items. This prevents your loops from having to cycle through non unique items when trying to test them.
Sub Test()
Dim Example(1, 1) As String
Dim NoDups() As String
Dim I, II, III As Long
ReDim NoDups(UBound(Example, 1) * UBound(Example, 2))
For I = 0 To UBound(Example, 1)
For II = 0 To UBound(Example, 2)
For III = 0 To UBound(NoDups)
If NoDups(III) = Example(I, II) Then
Exit For
ElseIf NoDups(III) = "" Then
NoDups(III) = Example(I, II)
Exit For
End If
Next
Next
Next
End Sub
To work through a 2D array, do as you would with a 1D array, but with a 'width' loop inside of a 'height' loop.
ie:
for a = 1 to number_of_elements_in_first_dimension
for y = 1 to number_of_elements_in_second_dimension
initial_comparison_string = array(a,b)
for x = a to number_of_elements_in_first_dimension
for y = b + 1 to number_of_elements_in_second_dimension
if Initial_comparison_string = array(x,y) then array(x,y) = ""
next y
next x
next b
next a
This will run fairly slowly with a very large 2D array, but I think you'd have to do 2 nested loops like this to take each value and compare it against each value which appears later.

get length of each sub array of a array vba

I have input array {{1,4}, {1,3}, {1,4,7}}
Dim array1() As Long
ReDim array1(3, 3)
array1(1, 1) = 1
array1(1, 2) = 4
array1(2, 1) = 1
array1(2, 2) = 3
array1(3, 1) = 1
array1(3, 2) = 4
array1(3, 3) = 7
I would like to have output array (which is length of each subarray) {2,2,3}
I am thinking to use for loop as following
Dim i As Long
i = UBound(array1, 1)
Dim outputarray() As Long
ReDim outputarray(i) As Long
For j = 1 To i
outputarray(i) = UBound(array1(i), 2) 'ERROR APPEAR
Next j
i added Option Base 1
The length of each subarray stay the same, its always 3 in your case. Your redim has defined the number you want to get. So there's no point trying to retrieve it like you want to do.
The fact that you don't move any values in
array1(1, 3)
array1(2, 3)
doesn't affect the dimensions of your array. You'll find values in these what-you-think-empty array's cells, and it will be 0 because you declared your array as long. If you had declared it as string, you would find a blank string in them, neither null nor "nothing".
You have input array {{1,4,0}, {1,3,0}, {1,4,7}}
If your aim is to find which elements of your array are 0 because you didn't moved anything in them, that's another story not related to the length of your array.
I agree with Thomas' answer above.
If you do find yourself interested in knowing the number of populated array values in the array, you might consider the following:
Start with the first row, and the right-most value in that array. So your for loop would actually be two loops - one to go through the first dimension, and one to go through the second dimension.
Move left through the array until you run into a non-zero value. Keep a count of the total values that are zero. When you run into a non-zero value, subtract the total zero values from the second dimension of the array. This will give you the "length" that you were looking for before.
So for example:
Dim i As int
Dim j As int
Dim h As int
Dim w As int
h = UBound(array1, 1)
w = UBound(array1, 2)
Dim rowVals as int
Dim arrVals as int
For i = 0 To h
rowVals = 0
For j = w to 0 Step -1
if array1(i,j) = 0 Then
exit for
else
rowVals = rowVals + 1
end if
Next
arrVals = arrVals + rowVals
Next

Resources