increase value of an element in array vba - arrays

I am working in VBA for Excel, and I have an array of integers. What I am trying to do is add 1 to a specific element inside the array when my conditions have been met. In my example code if the cell in column A is a 5 then I would like to add 1 in the 5th position of the array or if the cell is a 3 then add 1 to the 3rd position of the array.
Sub CountCustomers()
Dim myArray(5)
Dim i as integer
For i = 1 to 10
If Cells(i,1) = 5 Then
myArray(4) = myArray(4)+1
ElseIf Cells(i,1) = 3 Then
myArray(2) = myArray(2)+1
End If
Next
End Sub
When I run it like this it ends up with a 1 in the correct position but will not increase the values any higher. Is there a way to do this?

A couple of options below.
Better to work with arrays for speed than loops (option 2)
For this particular example you can use CountIF directly (option 1)
If you have multiple processing routes then Select can be more efficient than Else If
code #1
Sub Option1()
Debug.Print "number of 5's: " & Application.WorksheetFunction.CountIf([a1:a10], 5)
Debug.Print "number of 3's: "; Application.WorksheetFunction.CountIf([a1:a10], 3)
End Sub
code #2
Sub Option2()
Dim x
Dim myArray(1 To 5)
Dim lngCnt As Long
'put range into 2D variant array
x = [a1:a10].Value2
For lngCnt = 1 To UBound(x)
Select Case x(lngCnt, 1)
Case 5
myArray(4) = myArray(4) + 1
Case 3
myArray(2) = myArray(2) + 1
Case Else
'do nothing
End Select
Next
Debug.Print myArray(4), myArray(2)
End Sub

Your code works as expected. You should watch:Excel VBA Introduction Part 3 - What to do When Things Go Wrong (Errors and Debugging)
Here I set up watches to monitor your variables. The watches for myArray(2) and myArray(4) are set to break when there value changes.

Related

VBA - How to take a single column as input array then output the array removing all odd numbers

I have a very basic question, but would love to know how to do this. I want to write a function in VBA where I can highlight a column as an input, and then spit out the result somewhere else.
Thanks in advance :)
e.g. column A
--------
10
8
5
6
1
3
2
becomes:
column A
--------
10
8
6
2
I just did it from column a to b, but you probably want range as the current selection and a different output column.
Option Explicit
Sub filterlist()
Dim rng As Range
Set rng = Range("a1:a5")
Dim celluse As Range
Dim arr As Variant
For Each celluse In rng
If celluse.Value Mod 2 = 0 Then
If IsEmpty(arr) Then
arr = Array(celluse.Value)
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = celluse.Value
End If
End If
Next celluse
Dim i As Long
For i = 0 To UBound(arr)
Range("b" & i + 1) = arr(i)
Next i
End Sub
This code should do the trick.
You can enter as an array-formula directly to a sheet: {=RemoveOdds(A1:A7)} or as part of another procedure:
Sub Test()
RemoveOdds Selection
End Sub
Public Function RemoveOdds(Target As Range) As Variant
Dim vFinal() As Variant
Dim rCell As Range
Dim x As Long
ReDim vFinal(1 To Target.Cells.Count)
x = 1
For Each rCell In Target
If rCell Mod 2 = 0 Then
vFinal(x) = rCell.Value
x = x + 1
End If
Next rCell
'So missing values do not show up as 0 at bottom of array.
' Do While x <= Target.Cells.Count
' vFinal(x) = ""
' x = x + 1
' Loop
ReDim Preserve vFinal(1 To x - 1)
'RemoveOdds = vFinal 'Basic array - will place values horizontally on sheet.
RemoveOdds = Application.Transpose(vFinal) 'Will place values vertically on sheet.
End Function

Reduce amount of dimensions in an array

I have Range(one dimensional), that I want to summarize in one cell by concatenating all values. I thought that I could do just:
Dim Data_array()
Dim Source_Range as Range
Set Source_Range = Selection
Data_array() = Source_Range.Value2
Source_range.Offset( -1 ,0).Value = Join(Data_array, ", ")
This however returns error 5 because Data_array is a ( 1 To X, 1 To 1) array it has two dimensions, and Join on last line requires that you provide just one dimenstional array.
So my question would be is there a way to remove that "1 To 1" dimension?
If not how would you concatenate a one dimensional range in one cell.
Example
A
1
2 2
3 4
4 6
Desired Result
A
1 2, 4, 6
2 2
3 4
4 6
You were so close! The code below assumes you will select the cells below the empty target cell. I't is simply two tweaks from your original code:
Sub testing()
Dim Data_array()
Dim Source_Range As Range
Set Source_Range = Selection
Data_array() = WorksheetFunction.Transpose(Source_Range.Value2)
Source_Range.Offset(-1, 0).Resize(1, 1).Value = Join(Data_array, ", ")
End Sub
Below is an idea. NOTE: I'm not sure that the OFFSET part of your code does what you want it to do. Test the code, and let me know if so.
Dim Data_array()
Dim Source_Range As Range
Dim nIncrement As Integer
Set Source_Range = Selection
nIncrement = 1
ReDim Data_array(1 To Source_Range.Rows.Count)
For Each cel In Source_Range
Data_array(nIncrement) = cel.Value
nIncrement = nIncrement + 1
Next cel
Source_Range.Offset(-1, 0).Value = Join(Data_array, ", ")
For your data, I would not bother with a VBA array. Consider:
Public Function Konkat(rin As Range) As String
For Each r In rin
v = r.Value
If v <> "" Then
Konkat = Konkat & "," & v
End If
Next r
Konkat = Right(Konkat, Len(Konkat) - 1)
End Function
This is because in your code, data_Array is actually a two-dimensional array.
You can use the INDEX worksheet function to slice out a column or row.
Sub JoinRangeComma()
Dim vaData As Variant
Dim rSource As Range
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Set rSource = Selection
vaData = rSource.Value2
rSource.Cells(1).Offset(-1, 0).Value = Join(wf.Index(wf.Transpose(vaData), 1, 0), ", ")
End Sub

How to add arrays?

I have the following problem in Excel while calculating through a loop:
I need a variable (Destination Variable) that sequentially stores the results produced after each loop has been completed (avoiding the use of circular references) that would look like this:
'Let's call it "origin" variable in the worksheet
Origin Variable (50 x 50 array)
1 2 4
2 3 4
2 2 3
'Let's call it "destination" variable in the worksheet
Destination Variable (50 x 50 array)
1 1 1
1 1 1
1 1 1
After each loop, I'd need the macro to perform the following code:
range("destination").value = range("destination").value + range("origin").value
So that the destination variable would look like this after the current loop:
Destination Variable
2 3 5
3 4 5
3 3 4
However, Excel does not allow me to perform the previous function.
Does anyone have an answer how this could be solved?
Quite easy. I did this by recording as macro and tidying.
Sub Macro1()
Range("origin").Copy
Range("destination").PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
I like #S Meaden's answer, it is simple and I had not thought of that. And it certainly works for this purpose.
You could also do simple iteration. IN the example below I add two different ranges and put them in a third range, but this could be re-worked for your needs pretty easily, or it is another option if you ever need to add ranges to another range:
Sub AddArrays()
Dim rng1 As Range
Dim rng2 As Range
Dim rngSum As Range
Dim arr1 As Variant
Dim arr2 As Variant
Dim arrSum As Variant
Set rng1 = Range("A1:C7") '## Modify as needed
Set rng2 = Range("F1:H7") '## Modify as needed
Set rngSum = Range("K1:M7") '## Modify as needed
'Raises an error, Type Mismatch
'rngSum.Value = rng1.Value + rng2.Value
arr1 = rng1.Value
arr2 = rng2.Value
arrSum = rngSum.Value
Dim x As Integer, y As Integer
For x = LBound(arr1, 1) To UBound(arr1, 1)
For y = LBound(arr1, 2) To UBound(arr1, 2)
arrSum(x, y) = arr1(x, y) + arr2(x, y)
Next
Next
'Print result to sheet
rngSum.Value = arrSum
End Sub

Print Dynamic Error Array to Sheet

I'm having troubles getting my Error array to print to a range. I'm fairly sure I'm resizing it incorrectly, but I'm not sure how to fix it. I created a test add which just added garbage data from columns A and B, but normally AddPartError would be call from within various Subs/Functions, and then at the end of the main script process the array should be dumped onto a sheet. Here are the relevant functions:
Sub testadd()
For Each i In ActiveSheet.Range("A1:A10")
Call AddPartError(i.value, i.Offset(0, 1))
Next i
tmp = PartErrors
PrintArray PartErrors, ActiveWorkbook.Worksheets("Sheet1").[D1]
Erase PartErrors
tmp1 = PartErrors
PartErrorsDefined = 0
End Sub
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), 2) = Data
End Sub
Private Sub AddPartError(part As String, errType As String)
If Not PartErrorsDefined = 1 Then
ReDim PartErrors(1 To 1) As Variant
PartErrorsDefined = 1
End If
PartErrors(UBound(PartErrors)) = Array(part, errType)
ReDim Preserve PartErrors(1 To UBound(PartErrors) + 1) As Variant
End Sub
Ok. I did a bit of checking and the reason this doesn't work is because of your array structure of PartErrors
PartErrors is a 1 dimensional array and you are adding arrays to it, so instead of multi dimentional array you end up with a jagged array, (or array of arrays) when you actually want a 2d array
So to fix this, I think you need to look at changing your array to 2d. Something like the below
Private Sub AddPartError(part As String, errType As String)
If Not PartErrorsDefined = 1 Then
ReDim PartErrors(1 To 2, 1 To 1) As Variant
PartErrorsDefined = 1
End If
PartErrors(1, UBound(PartErrors, 2)) = part 'Array(part, errType)
PartErrors(2, UBound(PartErrors, 2)) = errType
ReDim Preserve PartErrors(1 To 2, 1 To UBound(PartErrors, 2) + 1) As Variant
End Sub
and
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 2), 2) = Application.Transpose(Data)
End Sub
NB. You also need to Transpose your array to fit in the range you specified.
You code is a little hard to follow, but redim clears the data that is in the array, so I think you need to use the "Preserve" keyword.
Below is some example code you can work through to give you the idea of how it works, but you will need to spend some time working out how to fit this into your code.
Good luck!
Sub asda()
'declare an array
Dim MyArray() As String
'First time we size the array I do not need the "Preserve keyword
'there is not data in the array to start with!!!
'Here we size it too 2 by 5
ReDim MyArray(1, 4)
'Fill Array with Stuff
For i = 0 To 4
MyArray(0, i) = "Item at 0," & i
MyArray(1, i) = "Item at 1," & i
Next
' "Print" data to worksheet
Dim Destination1 As Range
Set Destination1 = Range("a1")
Destination1.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).Value = MyArray
'Now lets resize that arrray
'YOU CAN ONLY RESIZE THE LAST SIZE OF THE ARRAY - in this case 4 to 6...
ReDim Preserve MyArray(1, 6)
For i = 5 To 6
MyArray(0, i) = "New Item at 0," & i
MyArray(1, i) = "New Item at 1," & i
Next
'and let put that next to our first list
' "Print" data to worksheet
Dim Destination2 As Range
Set Destination2 = Range("A4")
Destination2.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).Value = MyArray
End Sub

filter values in column with a loop?

I am trying to program a simple loop to run through the user selected values and filter out some number display and the numbers I want in a different column.
I have 10 random numbers in a column in this order:
3
7
10
12
5
2
7
13
9
23
I essentially want to ignore the first value, retrieve the next two values, skip the fourth
value, retrieve the next two values and so on. So my output would be:
7
10
5
2
13
9
All I have is a loop that runs through the column. I think I would have to use the mod() function but I can't sem to get it right. All I have so far is this empty loop:
Sub findValues()
Do While Cells(x, 3).Value <> "" 'go through values in column 3 until empty cell is encountered
'skip first value
'retrieve next two values and put them in different column
'...
Loop
End Sub
Here's one solution to do it using a loop and Step 3.
It's not the fastest or optimized way, but it's one of many methods that works and this method is rather simplistic. The example assumes that the data is in column A and the new list will be output to column B.
Since you want to skip the first value, I start the loop at A2, then do a Step 3 each loop (but copy over 2 elements, so it'll always skip the 3rd element).
Sub test()
Application.ScreenUpdating = False
Dim i As Long, j As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
j = 1
For i = 2 To lastRow Step 3
Cells(j, 2).Value = Cells(i, 1).Value
Cells(j + 1, 2).Value = Cells(i + 1, 1).Value
j = j + 2
Next
Application.ScreenUpdating = True
End Sub
Note that using Cells(row, column) is better for looping than Range() notation (and faster, too).
[Update: formula solution]
enter this in D1 and copy down 2/3 the length of your C column
=IF(MOD(ROW(),2)=1,OFFSET($C$1,INT(ROW()/2)*3+1,0),OFFSET($C$1,INT(ROW()/2)*3-1,0))
[initial post]
I've used a variant array as its more efficient (albeit slightly more complex) than a loop
In short what you were looking for is a Mod function where
(Row-1) Mod 3 = 0
should be excluded
ie exclude position 1,4,7 etc
This code dumps the output from column C to D. It will cater for as many values that exist in C (note I have set the c range by looking up from bottom not down from top, so blanks wont through the code out)
Sub GetValues()
Dim rng1 As Range
Dim lngCnt As Long
Dim lngCnt2 As Long
Dim X
Dim Y
Set rng1 = Range([c1], Cells(Rows.Count, "C").End(xlUp))
X = rng1
ReDim Y(1 To 2 / 3 * rng1.Cells.Count, 1 To 1)
For lngCnt = 1 To UBound(X, 1)
If (lngCnt - 1) Mod 3 <> 0 Then
lngCnt2 = lngCnt2 + 1
Y(lngCnt2, 1) = X(lngCnt, 1)
End If
Next
[d1].Resize(UBound(Y, 1), 1) = Y
End Sub]

Resources