I have some data, stored in arrays like
Dim arrA, arrB, arrC, arrAi, arrBi
Dim i as integer, x as integer
for i = 1 to 100
if cells(i,1).value = "criteria" then ' just add value to array when it meets some criteria
x = x + 1
arrA(x) = cells(i,1).value
arrB(x) = cells(i,2).value
arrC(x) = cells(i,3).value
end if
next i
redim preserve arrA(1 to x)
redim preserve arrB(1 to x)
redim preserve arrC(1 to x)
And the data looks like
arrA: 26.1 40.2 80.3 26.0 41.3 78.7 25.8 40.8 80.0
arrB: 10 11 10 66 67 64 32 32 33
arrC: 1 2 3 1 2 3 1 2 3
Since the values in arrA 26.1, 26.0, 25.8 (position 1, 4, 7) belong to group 1 (referencing to values in arrC at same position), I would like to store 26.1 26.0 25.8 to arrAi and 10 66 32 to arrBi for subsequent calculations.
How can I loop through the 3 arrays and store values to another array as described above?
Thanks in advance.
Try the next way, please:
Sub handleArraysFromArrays()
'your existing code...
'but you fistly must declare
Dim arrA(1 To 100), arrB(1 To 100), arrC(1 To 100)
'....
'your existing code
'...
Dim k As Long, kk As Long
ReDim arrAi(1 To UBound(arrA))
ReDim arrBi(1 To UBound(arrA))
For i = 1 To UBound(arrC)
If arrC(i, 1) = 1 Then k = k + 1: arrAi(k, 1) = arrA(i, 1)
If arrC(i, 1) = 2 Then kk = kk + 1: arrBi(kk, 1) = arrA(i, 1)
Next i
ReDim Preserve arrAi(1 To k): ReDim Preserve arrBi(1 To kk)
Debug.Print UBound(arrAi), UBound(arrBi)
End Sub
Related
I need to loop in a range (in my case column A) to get following results:
A B
1 = 2 - 1
2 = 3 - 1
3 = 3 - 2
4 = 4 - 1
5 = 4 - 2
= 4 - 3
= 5 - 1
= 5 - 2
= 5 - 3
= 5 - 4
I want number 5 to be deducted by 4, 3, 2 ,1 and then number 4 by 3, 2, 1 and so on.
I was somehow able to achieve this with collection but since dataset is rather big script is running 30+ minutes.
At this point I'm trying to figure out arrays but I don't know how to get desired result. My main concern is whether I can loop from bottom to top (From number 5 to 1, not 1 to 5) and how to fixate last row (fix number 5, conduct deductions and then fix number 4, do math magic and loop to 3 and so on).
My current code is:
Dim Arr As Variant
Dim lastc, lastr As Long
lastc = FindColNumber
lastr = ws.Cells(ws.Rows.count, lastc).End(xlUp).Row
Arr = ws.Range(ws.Cells(2, last), ws.Cells(lastr, lastc))
For i = LBound(Arr, 1) To UBound(Arr, 1) - 1
If (Arr(i, 1) > 0) And (Arr(i + 1, 1) > Arr(i, 1)) Then
Arr(i, 1) = Arr(i, 1) - Arr(i + 1, 1)
Code does deduction as following: 5-4, 4-3, 3-2, 2-1 and that's not what I need.
Any tips?
Thank you.
As stated in the comments, you will need two loops and another output array:
Sub lkjlkjkdl()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim Arr As Variant
Dim lastc As Long, lastr As Long
lastc = 1 'FindColNumber
lastr = ws.Cells(ws.Rows.Count, lastc).End(xlUp).Row
Arr = ws.Range(ws.Cells(2, lastc), ws.Cells(lastr, lastc))
Dim cnt As Long
cnt = ((UBound(Arr, 1) - 1) * UBound(Arr, 1)) / 2
Dim k As Long
k = 1
Dim outarr As Variant
ReDim outarr(1 To cnt, 1 To 1)
For i = LBound(Arr, 1) + 1 To UBound(Arr, 1)
Dim j As Long
For j = LBound(Arr, 1) To i - 1
outarr(k, 1) = Arr(i, 1) - Arr(j, 1)
k = k + 1
Next j
Next i
ws.Range("B2").Resize(cnt, 1).Value = outarr
End Sub
I'm trying to assign a 1-dimensional array's values to cell range.
For example; my array has 23 items (every item randomized from 1 to 5) and my cell range is range A1 to I7.
I want to assign every value of my array to this cell range randomly.
I randomize the cell values with my array but my array's values are not completely assigned to cells.
Sub define_ore_body()
Dim lb_grade As Integer, ub_grade As Integer
Dim ore_body(1 To 23) As Variant
Dim i As Integer, j As Integer, k As Integer
Dim a As Object
Dim b As Range
Application.ScreenUpdating = False
'my selected range area A1toI7
Set b = Application.Range("A1:I7")
Set a = Application.Cells
'******* low and high ore bound ******
lb_grade = InputBox("Enter lowest ore grade:")
ub_grade = InputBox("Enter highest ore grade:")
'The reason why I do it as follows is that if the random lower bound does not start from 1,
'the largest random number it generates is 2 more than the value I have entered, so
If lb_grade > 1 Then
ub_grade = ub_grade - 2
End If
'******* Random Array ******
'array has 23 items
For i = 1 To 23
ore_body(i) = Int((ub_grade * Rnd) + lb_grade)
Next i
'******* filling random cells with my array******
k = 1
For Each a In b
If a.Value = "" And k < 23 Then
b(Int(7 * Rnd + 1), (8 * Rnd + 1)) = ore_body(k)
ElseIf a.Count > 23 And k > 23 Then
Exit For
Else
k = k + 1
End If
Next a
'******* after filling cell now fill empty cells with Zero******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) = "" Then
Cells(i, j) = 0
Else
End If
Next j
Next i
'******* Coloring only containing array values******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) > 0 Then
Application.Cells(i, j).Interior.ColorIndex = 38
Else
End If
Next j
Next i
End Sub
The array contains 23 items that initialize to Variant/Empty:
Dim ore_body(1 To 23) As Variant
Make that 63 items that initialize to 0:
Dim ore_body(1 To 63) As Long
The rest of the code will now populate the first 23 elements, because that's what the loop does:
For i = 1 To 23
If you want the loop to run through all indexes, consider using LBound and UBound operators to programmatically retrieve the lower and upper boundaries of the array, respectively:
For i = LBound(ore_body) To UBound(ore_body)
Note that you have 23 hard-coded in several places, which is going to make it harder than necessary to modify if/when that 23 needs to be come a 25. Consider replacing every occurrence of it by a Const:
Const ElementCount As Long = 23
Then every instance of 23 can become ElementCount, and then when it needs to become 25 then there's only one place that needs any code to change.
Loop through the array.
Set a to a random cell in the range A1:I7.
If cell is empty put the value from the array in the cell, if it
isn't repeat step 2
Sub define_ore_body()
Dim lb_grade As Integer, ub_grade As Integer
Dim ore_body(1 To 23) As Variant
Dim i As Long, j As Long, k As Long
Dim a As Range
Dim b As Range
Application.ScreenUpdating = False
'my selected range area A1:I7
Set b = Application.Range("A1:I7")
' clear A1:A17
b.Clear
'******* low and high ore bound ******
lb_grade = InputBox("Enter lowest ore grade:")
ub_grade = InputBox("Enter highest ore grade:")
'The reason why I do it as follows is that if the random lower bound does not start from 1,
'the largest random number it generates is 2 more than the value I have entered, so
If lb_grade > 1 Then
ub_grade = ub_grade - 2
End If
'******* Random Array ******
'array has 23 items
For i = 1 To 23
ore_body(i) = Int((ub_grade * Rnd) + lb_grade)
Next i
'******* filling random cells with my array******
For k = 1 To 23
Do
Set a = b.Cells(Int(7 * Rnd) + 1, Int(9 * Rnd) + 1)
Loop Until a.Value = ""
a.Value = ore_body(k)
Next k
'******* after filling cell now fill empty cells with Zero******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) = "" Then
Cells(i, j) = 0
Else
End If
Next j
Next i
'******* Coloring only containing array values******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) > 0 Then
Application.Cells(i, j).Interior.ColorIndex = 38
Else
End If
Next j
Next i
End Sub
I want to swap values into a multidimensional array which are not #N/A or not 0 for each row. So the input table is on a spreadsheet with contains the numbers below, the problem is I can't swap them how I want.
24 20 0 #N/A #N/A #N/A
21 20 0 #NA #N/A #N/A
25 24 20 0 #N/A #N/A
26 25 24 20 0 #N/A
28 26 25 24 20 0
Do you have any suggestion how to deal with that?
Sub FlipRows()
Dim Rng As Range
Dim WorkRng As Range
Dim arr As Variant
Dim i As Integer, j As Integer, k As Integer
Dim matrix As Range, matrix2 As Range
Set matrix = Range("A1:F5")
Set matrix2 = Range("A7:F11")
'Set tempMatrix as String, tempMatrix2 as String
On Error Resume Next
'matrix.Select
'matrix.Copy
'matrix2.Select
'matrix2.PasteSpecial
Set WorkRng = Application.Selection
arr = WorkRng.Formula
For i = 1 To UBound(arr, 1)
k = UBound(arr, 2)
For j = 1 To UBound(arr, 2) / 2
xTemp = arr(i, j)
arr(i, j) = arr(i, k)
arr(i, k) = xTemp
k = k - 1
Next
Next
WorkRng.Formula = arr
End Sub
Assuming you invalid values (0 and #NA) are always on the right of each row, this should do:
For i = LBound(arr, 1) To UBound(arr, 1)
'first search backward the first valid entry
For k = UBound(arr, 2) To LBound(arr, 2) Step -1
If Not IsError(arr(i, k)) Then If arr(i, k) <> 0 And arr(i, k) <> "#NA" Then Exit For
Next
'Now do the swap in the valid region
For j = LBound(arr, 2) To Int(k / 2)
Dim temp: temp = arr(i, j)
arr(i, j) = arr(i, LBound(arr, 2) + k - j)
arr(i, LBound(arr, 2) + k - j) = temp
Next
Next
WorkRng.Formula = arr
Assuming you always have a zero value after the values you want to swap
Sub swap()
Set r = Range("A1:F5")
For Each ro In r.Rows
Set re = ro.Find(0, lookat:=xlWhole)
co = re.Column
For c = 1 To (co - 1) / 2
a = ro.Cells(1, c)
ro.Cells(1, c) = ro.Cells(1, co - c)
ro.Cells(1, co - c) = a
Next c
Next ro
End Sub
Below I have a list of “ID” numbers with their associated “Number “and their “values”. I am trying to create sub function that crates a dynamic array that collects all the “Values” that have a “Number” that is equal to and lesser than 30. After the array is filled it is summed and placed under the heading titled “30 or less”. I have been trying do this using VBA with no luck. I have read a bunch of posts and documents telling me how to do this but I can’t make sense of it. Could someone show me how to get this done. Its driving me crazy and I am sure its simple I eventually want to expand this to do the same with “Numbers ” that are greater than 30 but less than 60 and so on. Thank you
ID Number Value
0 60 100
1 31 101
2 12 102
3 30 103
4 21 104
5 60 105
30 or less
Try pasting this into a new module in VB.
This presumes that your Raw data is in Sheet(1) and sorted data will be in a new blank worksheet Sheet(2)
Sub AddNumbers()
Dim RowNo, ColNo As Long
'Skip Header Row
RowNo = 2
Do Until Sheets(1).Cells(RowNo, 1) = ""
If Sheets(1).Cells(RowNo, 2) <= 30 Then
Sheets(2).Cells(1, 1) = "30 or less"
ColNo = 1
Sheets(2).Cells((Sheets(2).Cells(Rows.Count, 1).End(xlUp).row + 1), ColNo) = Sheets(1).Cells(RowNo, 3)
ElseIf Sheets(1).Cells(RowNo, 2) > 30 And Sheets(1).Cells(RowNo, 2) <= 60 Then
Sheets(2).Cells(1, 2) = "Between 30 and 60"
ColNo = 2
Sheets(2).Cells((Sheets(2).Cells(Rows.Count, 2).End(xlUp).row + 1), ColNo) = Sheets(1).Cells(RowNo, 3)
ElseIf Sheets(1).Cells(RowNo, 2) > 60 And Sheets(1).Cells(RowNo, 2) <= 90 Then
Sheets(2).Cells(1, 3) = "Between 60 and 90"
ColNo = 3
Sheets(2).Cells((Sheets(2).Cells(Rows.Count, 3).End(xlUp).row + 1), ColNo) = Sheets(1).Cells(RowNo, 3)
End If
RowNo = RowNo + 1
Loop
' Add Subtotals
ColNo = 1
Do Until Sheets(2).Cells(1, ColNo) = ""
Sheets(2).Cells((Sheets(2).Cells(Rows.Count, ColNo).End(xlUp).row + 1), ColNo).Formula = "=SUM(" & Col_Letter(ColNo) & "2:" & Col_Letter(ColNo) & (Sheets(2).Cells(Rows.Count, ColNo).End(xlUp).row) & ")"
Sheets(2).Cells((Sheets(2).Cells(Rows.Count, ColNo).End(xlUp).row), ColNo).Font.Bold = True
ColNo = ColNo + 1
Loop
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
EDIT: Updated question using some of the suggestions below. This produces weird output though.
Dim ProviderArray() As Variant
Sub GetProviderNumbers()
Dim InputRange As Range
Dim WorkRange As Range
Set InputRange = Range("ProviderList")
Set WorkRange = Application.Intersect(InputRange, ActiveSheet.UsedRange)
SizeOfArray = Application.WorksheetFunction.CountA(WorkRange)
ReDim ProviderArray(0 To SizeOfArray)
ProviderArray = WorkRange.Value
For r = 1 To UBound(ProviderArray, 1)
For C = 1 To UBound(ProviderArray, 2)
Debug.Print r, C, ProviderArray(r, C)
Next C
Next r
End Sub
1 1 5555
2 1 4444654
3 1 654654
4 1 654654654
5 1
6 1
7 1
8 1
9 1
10 1
11 1
12 1
13 1
14 1
15 1
16 1
17 1
18 1
19 1
Could someone explain why this output?
You can only use the one-line approach if you put the range into a 2-D array: you only have a 1-D array.
You could do this:
Dim ProviderArray()
Set WorkRange = .Intersect(InputRange, ActiveSheet.UsedRange)
'This makes ProviderArray a 2-D array, dimension 1 = # rows,
' dimension2 = #cols. Both dimensions are 1-based.
ProviderArray = WorkRange.value
for r=1 to ubound(ProviderArray,1)
for c=1 to ubound(ProviderArray,2)
debug.print r,c,ProviderArray(r,c)
next c
next r
Maybe something a bit simpler like:
Private Sub GetProviderNumbers()
Dim InputRange() As Variant
InputRange = Range("ProviderList")
For Each i In InputRange
Debug.Print i
Next
End Sub
This captures a two-dimensional range and stores the values in a global two-dimensional array:
Dim ProviderArray() As String
Sub MAIN()
Range("B2:C11").Name = "ProviderList"
Call GetProviderNumbers
End Sub
Sub GetProviderNumbers()
ary = Range("Providerlist")
ll = LBound(ary, 1)
lm = LBound(ary, 2)
ul = UBound(ary, 1)
um = UBound(ary, 2)
ReDim ProviderArray(ll To ul, lm To um)
For i = ll To ul
For j = lm To um
ProviderArray(i, j) = ary(i, j)
Next
Next
End Sub