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
Related
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
I have the below snippit for excel 2013 VBA
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
ReDim Preserve testArr(1 To FNum, 1 To 23)
testArr(FNum) = r
End If
Next r
My goal is to get all the visible rows from a filtered table into an array.
The table can be any number of rows, but always 23 columns.
I found that the height will be zero if it is hidden. But for the life of me, I cannot figure out how to get the entire row into the array.
r = listrow
rr = listrows
YES, I know a looping redim sucks.
SpecialCells(xlCellTypeVisible)
doesnt work either because it stops at the first hidden row/column.
I may just dump the entire table into the array and then filter the array. I havent figured out how to pull the active filter from the table to apply it, but I havent looked deeply into that yet. Thats what I will be doing now, because I am stuck for the other way.
Any and all advice is welcome.
DM
To avoid REDIM or double loops you can use something like Application.WorksheetFunction.Subtotal(3, Range("A2:A500000")) to quickly count the number of visible rows.
See this question
I define my Target range using .SpecialCells(xlCellTypeVisible). Target.Cells.Count / Target.Columns.Count will give you the row count. Finally I iterate over the cells in the Target range incrementing my counters based off of the Target.Columns.Count.
Public Sub FilteredArray()
Dim Data As Variant, r As Range, Target As Range
Dim rowCount As Long, x As Long, y As Long
Set Target = WorkSheets("Sheet1").ListObjects("Table1").DataBodyRange.SpecialCells(xlCellTypeVisible)
If Not Target Is Nothing Then
rowCount = Target.Cells.Count / Target.Columns.Count
ReDim Data(1 To rowCount, 1 To Target.Columns.Count)
x = 1
For Each r In Target
y = y + 1
If y > Target.Columns.Count Then
x = x + 1
y = 1
End If
Data(x, y) = r.Value
Next
End If
End Sub
The code below will create an array for all the rows and store each of these into another array that will store all info in sheet:
Function RowsToArray()
Dim lastRow: lastRow = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastCol: lastCol = ActiveWorkbook.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim newArr()
ReDim newArr(lastRow)
For r = 0 To lastRow - 1
Dim rowarr()
ReDim rowarr(lastCol)
For c = 0 To lastCol - 1
rowarr(c) = Cells(r + 1, c + 1).Value
Next c
newArr(r) = rowarr
Next r
End Function
Can you loop over the cells in rr rather than the rows? If so, as #SJR says, you can only Redim Preserve the final dimension, so we're going to have to switch your dimensions. You can then use r.EntireRow.Hidden to check if we're in a visible row and increase the bound of your array by one if we are.
The following assumes that your data starts in column A:
For Each r In rr
If Not r.EntireRow.Hidden Then
If r.Column = 1 Then
If UBound(testArr, 2) = 0 Then
ReDim testArr(1 To 23, 1 To 1)
Else
ReDim Preserve testArr(1 To 23, 1 To UBound(testArr, 2) + 1)
End If
End If
testArr(r.Column, UBound(testArr, 2)) = r
End If
Next r
Edit:
Alternatively, you can keep using ListRows, but loop through twice, once to set the bounds of your array, and once to fill the array (which will have its own internal loop to run through the row...):
For Each r In rr
If Not r.Range.Height = 0 Then
Fnum = Fnum + 1
ReDim testArr(1 To Fnum, 1 To 3)
End If
Next r
Fnum = 0
For Each r In rr
If Not r.Range.RowHeight = 0 Then
Fnum = Fnum + 1
dumarray = r.Range
For i = 1 To 3
testArr(Fnum, i) = dumarray(1, i)
Next i
End If
Next r
Thanks all, a combo of answers led me to: (not very elegant, but quick)
For Each r In rr
If Not r.Range.Height = 0 Then
TNum = TNum + 1
End If
Next r
ReDim testArr(TNum, 23)
For Each r In rr
If Not r.Range.Height = 0 Then
FNum = FNum + 1
For i = 1 To 23
testArr(FNum, i) = r.Range.Cells(, i)
Next i
End If
Next r
I have a Variant in VB6 with thousands of Strings.
I also have an array of fixed length.
I need to compare the contents of each and add the ones that match to a list.
if array(i) = variant(1,i) then
'add to list
End if
I cannot figure out how to iterate over both properly in order to compare, as the method I use to iterate over the Variant() stops after going through each item. So it never checks to see if it any item is equal to i+1 in the array.
Private Sub dp_Click()
Dim fArray
fArray = Array("a", "b", "c")
LstAPens.ListItems.Clear
LstUPens.ListItems.Clear
For x = 0 To UBound(fArray)
Dim i As Long, m As Integer
'Do Until batcharray(0, i) = "End"
' tmpArray(i) = UCase(batcharray(1, i))
'Loop
Do Until batcharray(0, i) = "End"
If (InStr(1, UCase(batcharray(1, i)), UCase(fArray(x))) > 0) Then
LstAPens.ListItems.Add
With LstAPens.ListItems(m + 1)
.SubItems(1) = batcharray(1, i) 'Tagname
End With
m = m + 1
End If
i=i+1
Loop
Next x
End Sub
I tried to convert the Variant to an array but it did not work.
The only item that is found is the first one in the array, then the Variant is no longer iterated over as it reached the end.
How can I iterate over the Variant called batchArray in this example, and compare it to the contents of an array?
This really isn't a Variant problem, it's just a looping/control variable issue.
Even though you have your DIM statement inside your main loop, VB does not treat that as a "redeclaration" and reset/reinitialize its value before your UNTIL loop. As a result, 'i' will increment to 1 and then retain its value between iterations of your outer loop, thus remaining stuck on the single value in batchArray and the iteration ceases.
Move the declaration outside the loop, reset it to 0 before the UNTIL loop, and see if that solves your problem:
Dim i as Long
For x = 0 To UBound(fArray)
Dim m As Integer
i = 0
Do Until batcharray(0, i) = "End"
If (InStr(1, UCase(batcharray(1, i)), UCase(fArray(x))) > 0) Then
LstAPens.ListItems.Add
With LstAPens.ListItems(m + 1)
.SubItems(1) = batcharray(1, i) 'Tagname
End With
m = m + 1
End If
i=i+1
Loop
Next x
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
Here's what I'm trying to do:
Suppose that you have a dynamic array whose dimensions can be from 0x6 up to 10x6 (meaning we can have rows anywhere from 0 to 10, but columns are always 6). I have been desperately trying to create a function (and then bind it to a macro) that will use as argument this first array, and will create a second array as output, whose elements will be the returns of the first array. For example, if we have the simple case of 1x6, then the output array's elements are five and in each case are given by the formula (x_i+1 - x_i)/x_i, i=1, 2, ..., 6. Additionally, the function must be able to bypass any missing values from the input array and ignore the corresponding non-existent return values. The entire thing must be done in VBA script.
It's been two days since I have been searching frantically for some help, but the problem is that I have no idea whatsoever about programming in VBA (I usually use other languages like MATLAB or Mathematica) so this is extremely hard for me. Any solutions that I have found I wasn't able to put together and achieve my goal. Any help is greatly appreciated.
Because you provided no code, I cannot determine exactly what you want to do, but here is an example of passing an array and returning an array that you should be able to extrapolate.
Edit: Just for fun, updated this to work for up to 3 dimensional arrays.
Public Sub Test()
'Defines testArray as Variant 0 to 10
Dim testArray(0 To 1, 0 To 6) As Long
Dim returnArray() As Long
Dim i As Long
Debug.Print UBound(testArray, 2)
'Populates testArray with Longs
For i = 0 To UBound(testArray, 1)
For j = 0 To UBound(testArray, 2)
testArray(i, j) = (i + j) * 2
Next
Next
'Passes testArray and returns ParseArray
returnArray = addOne(testArray)
End Sub
Public Function addOne(arrValues() As Long) As Variant
Dim arrCopy() As Long
Dim dimensionNum As Long, ErrorCheck As Long
On Error Resume Next
For dimensionNum = 1 To 60000
ErrorCheck = LBound(arrValues, dimensionNum)
If Err.Number <> 0 Then
dimensionNum = dimensionNum - 1
Exit For
End If
Next
Dim i As Long, j As Long, k As Long
'Copies passed array to avoid updating passed array directly
arrCopy = arrValues
'Adds 1 to each element of the array.
If dimensionNum = 1 Then
For i = LBound(arrCopy) To UBound(arrCopy)
arrCopy(i) = arrCopy(i) + 1
Next
ElseIf dimensionNum = 2 Then
For i = LBound(arrCopy) To UBound(arrCopy)
For j = LBound(arrCopy, 2) To UBound(arrCopy, 2)
arrCopy(i, j) = arrCopy(i, j) + 1
Next
Next
ElseIf dimensionNum = 3 Then
For i = LBound(arrCopy) To UBound(arrCopy)
For j = LBound(arrCopy, 2) To UBound(arrCopy, 2)
For k = LBound(arrCopy, 3) To UBound(arrCopy, 3)
arrCopy(i, j, k) = arrCopy(i, j, k) + 1
Next
Next
Next
Else
MsgBox "Add function only works for three dimensions or fewer arrays"
End If
addOne = arrCopy
End Function