I am looping through some data (only 8 values) in an Excel range from VBA, but I seem to be getting a 'phantom' empty array value in the middle.
Here is how I build the array. The range that it loops through results in 2 values being found, i.e. 2 values = 'rad'.
' arRoPtsXY is a 2D array
counter2 = UBound(arRoPtsXY, 2)
Dim arSecPtCt()
loopCtr = 0
For i = 1 To counter2
rad = Sqr((secCX - arRoPtsXY(1, i)) ^ 2 + (secCY - arRoPtsXY(2, i)) ^ 2)
If rad = secR Then
ReDim Preserve arSecPtCt(i)
arSecPtCt(loopCtr) = i
loopCtr = loopCtr + 1
End If
Next i
But when I perform this:
For a = LBound(arSecPtCt) To UBound(arSecPtCt)
Debug.Print arSecPtCt(a)
Next a
I get this output:
1
3
'end
Note, above, there are 2 blank spaces being output (after 3, I added 'end to show the spaces here), like the array 'space' exists, but it is empty.
If I do a debug.print UBound(arSecPtCt) I get '3', meaning 0,1,2,3 occupied array 'spaces'.
I just want my array to be:
1
3
As it is only the 1st and 3rd value that = 'rad'.
If I debug.print i during the if loop, it only outputs the 1 and 3, no spaces, so the loop seems to work, but I am just getting these extra blanks.
Hope someone can put me out my misery.
Many thanks in advance.
Jon
Try changing:
ReDim Preserve arSecPtCt(i)
to
ReDim Preserve arSecPtCt(loopCtr)
Related
I am struggling with a basic problem in VBA and would appreciate some help. I want to define a function which returns an array from a range without blanks, as shown below:
So when I call the function in the European Option cell, the function should return an array without any blanks, like on the right hand side.
This is the code I have so far:
Function portfolioX(N)
Dim MyArray(3)
Dim i As Integer
counter = 1
For i = 1 To N
If IsEmpty(i) Then
Next i
Else
portfolio = MyArray
MyArray (counter)
counter = counter + 1
Next i
End If
End Function
I am a newbie to VBA, so this could be completely wrong. Thanks!
If statement and loop are blocks of code. You can not interlace blocks of code.
Function portfolioX(N)
For i = 1 To N ' Block 1 starts
If IsEmpty(i) Then ' Block 2 starts
Next i 'Block 1 can't loop back because Block 2 has't closed
Else
portfolio = MyArray
MyArray (counter)
counter = counter + 1
Next i 'Block 1 can't loop back because Block 2 has't closed
End If ' Block 2
End Function
When coding it is code practice to write the complete loop structure then fill in the inner code.
I would write the For loop first
For i = 1 to N
next i
Next comes the If block
For i = 1 To N
If IsEmpty(i) Then
End If
Next i
And finally
Function portfolioX(N)
Dim MyArray(3)
Dim i As Integer
counter = 1
For i = 1 To N ' Block 1 Starts
If IsEmpty(i) Then Block 2 Starts
portfolio = MyArray
MyArray (counter)
counter = counter + 1
End If ' Block 2 Closes
Next i 'If the Loop Condition is meet, Block 1 Closes, else i is incremented and the loop starts over
End Function
Given what you are asking for, I've written a quick sub that will take whatever range you have highlighted and paste the values with the blank cells removed at the end of the row. Hopefully this can give you a start towards what you are hoping to accomplish.
Sub RemoveBlanks()
Dim OriginalRange As Range, WorkCell As Range, PasteCol As Integer
Set OriginalRange = Selection.Rows(1) 'Ensures only one row of data is selected
PasteCol = Range(Cells(OriginalRange.Row, ActiveSheet.UsedRange.Columns.Count + 2).Address).End(xlToLeft)
For Each WorkCell In OriginalRange
If Not IsEmpty(WorkCell) Then
Cells(OriginalRange.Row, PasteCol).Value = WorkCell.Value
PasteCol = PasteCol + 1
Next WorkCell
End Sub
Based on your question and comments in that thread, I understand that you wish to take a given range (supplied to the procedure) and print all non-empty values to some range starting on the same row in column R (the 18th column).
In a comment, you supply the ranges A1:A13 and A18:A21, but those do not match with your screenshot. I assume you meant row 1 (or some arbitrary row), columns 1 to 13 and columns 18 to 21.
Here is a solution to that problem:
Sub arrayPaster(rng As Range)
Dim s() As Variant, r() As Variant, j As Integer
ReDim r(1 To 1, 1 To 1)
s = rng.Value
j = 1
For i = 1 To UBound(s, 2)
If s(1, i) <> "" Then
ReDim Preserve r(1 To 1, 1 To j)
r(1, j) = s(1, i)
j = j + 1
End If
Next i
Range("R" & rng.Row).Resize(1, UBound(r, 2)).Value = r
End Sub
I ran into the following issue when dealing with adding to variable array sizes. The loop runs one time more then it should essentially. But I'm curious as to what would cause this behavior? Am I not quite understanding how the loop exit functions are being called?
Here's the code:
Module Module1
Sub Main()
Dim num(-1)
Dim i = 0
Console.WriteLine("Input numbers to be added, q to stop:")
Dim input
Dim total = 0
Do
ReDim Preserve num(UBound(num) + 1) : num(UBound(num)) = i 'resize the array each time before an element is added.
input = Console.ReadLine
If IsNumeric(input) Then 'attempt to break loop on non numeric input
num(i) = CInt(input)
i += 1
Else
Exit Do
End If
Loop
total = 0
For Each n In num
total += n
Next
Console.WriteLine(Join(num))
Console.WriteLine("Total: " & total)
Console.ReadLine()
For input: 1 2 3 4 5 q, the output I get is:
1 2 3 4 5 5
Total: 20
It adds the last element twice, which is interesting as it is not only running twice but somehow using the last numeric input even though the final input was not numeric. Does anyone know why that would be?
You both (jnb92, PankajJaju) should not grow the array before you are sure the input is numerical and has to be stored.
Dim input
Do
input = Console.ReadLine()
If IsNumeric(input) Then 'attempt to break loop on non numeric input
ReDim Preserve num(UBound(num) + 1)
num(UBound(num)) = CInt(input)
Else
Exit Do
End If
Loop
Update wrt comment:
Your
ReDim Preserve num(UBound(num) + 1) : num(UBound(num)) = i
assigns i to num for each input; your
num(i) = CInt(input)
overwrites that with your numerical input, but not for the terminating "q". So for your (one and only?) test case, the spurious last elemement is (accidentially) 5.
I've used your script and tried to create a working solution
Dim num, input, total, i
num = Array()
i = 0
Do
input = Inputbox("Input numbers to be added, q to stop:")
If IsNumeric(input) Then 'attempt to break loop on non numeric input
ReDim Preserve num(UBound(num) + 1) 'resize the array each time before an element is added.
num(i) = CInt(input)
i = i + 1
Else
Exit Do
End If
Loop
total = 0
For Each n In num
total = total + n
Next
msgbox Join(num)
msgbox "Total: " & total
Edit - Updated answer based on #Ekkehard.Horner comments
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.
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
I am trying to delete blank entries from an array that was loaded from a field called TY[L3 Name] (1 column, X rows long) from a data table in excel. The below code is intended to remove all blank values from the array (once it has been loaded with the range), and return a new array with rows that only have data in them. I will want to pass this array onto a collection later to remove duplicates, but I am trying to figure out why I can't get ride of the blanks first (now I am at a point where I just want to understand how to do this regardless if i pass this onto something else or not).
The code errors out at the ReDim Preserve line. I first sized the NewArr to the MyArr table, but had blank rows returned at the end. I then tried to resize it so I only had rows with data in them, but I cannot seem to get the NewArr() array to do this without an error.
I am using the immediate window to verify that there are no blank entries (currently 8 rows at the end of the TY[L3 Name] range).
Sub BuildArray()
' Load array
Dim MyArr()
Dim j As Long
' Size array
MyArr() = Range("TY[L3 Number]")
ReDim NewArr(LBound(MyArr) To UBound(MyArr), 1)
' For Loop to search for Blanks and remove from Array
' The Lbound and UBound parameters will be defined by the size of the TY[L3 Number] field in the TY Table
For i = LBound(MyArr) To UBound(MyArr)
If MyArr(i, 1) <> "" Then
j = j + 1
NewArr(j, 1) = MyArr(i, 1)
End If
Next i
ReDim Preserve NewArr(1 To j, 1) 'Error out here; "Subscript out of range." Can't seem to get this Array to new size without blank entries.
' Debug Window to show results of revised array.
Dim c As Long
For c = LBound(NewArr) To UBound(NewArr)
Debug.Print NewArr(c, 1)
Next
Debug.Print "End of List"
End Sub
Working through arrays can be tricky in VBA, but I think the example below will show you how a different strategy for populating the "No Blanks" Array might be work:
Suppose we start off with a single Worksheet, with the CoolRange named as shown:
Generating an array without blanks could be done like this:
Option Explicit
Sub BuildArrayWithoutBlanks()
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ThisWorkbook.Names("CoolRange").RefersToRange
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If AryFromRange(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = AryFromRange(Counter, 1)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
For Counter = LBound(AryNoBlanks) To UBound(AryNoBlanks)
Debug.Print (AryNoBlanks(Counter))
Next Counter
Debug.Print "End of List"
End Sub
So, to summarize, we:
Create a 1-D array for our eventual array with blanks removed
Iterate through our original array (with blanks)
Unless the array field is blank, we increase our non-blank counter, then add the value to the non-blank array, then expand the non-blank array
Blow away the last pesky empty field in our non-blank array
From your problem description, it sounds like you'll eventually be stripping away duplicates with a Collection -- love it. Out of curiosity, what will you use the non-blank-but-with-duplicates array for?
I have worksheet data to remove the lines with "Templates" in them and copy to a second worksheet. Same idea as removing blank lines. I copied the raw data to INArr. I know the width is 16 (Columns) but the length (Rows) is variable. REDIM PRESERVE only works on the last dimension so I transposed the array so it is now 16 rows and unlimited columns while removing the unwanted data. Transpose the array back and copy to the final work sheet.
Hope that makes sense.
'Copy data from Worksheet3 to INArr, Remove "TEMPLATES" and copy to Worksheet2
LR = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
INArr = Sheet3.Range("B6:Q" & LR).Value2
ReDim TempArr(1 To 16, 1 To 1)
x = 0
For i = 1 To UBound(INArr)
If INArr(i, 14) <> "TEMPLATES" Then
x = x + 1
ReDim Preserve TempArr(1 To 16, 1 To x)
For j = 1 To 16
TempArr(j, x) = INArr(i, j)
Next
End If
Next
ReDim OutArr(1 To x, 1 To 16)
For i = 1 To x
For j = 1 To 16
OutArr(i, j) = TempArr(j, i)
Next
Next
Sheet2.Range("A3:P" & x + 2).Value2 = OutArr