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
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 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
I have a little problem with my sub. This sub is calling to different functions, by using the sub's data. The first function finds one is finding the amount of unique values and the second function finds these values. However, the first function works fine because its output is a scalar value. However, the second function's output is an array. I have tried to search for a solution, but so far I have not succeeded. I have a theory that the issue has something to do with the ByRef A() As Integer. I have written the codes below, both for the sub and the second function.
Sub Test()
Dim A() As Integer
Dim n As Integer
Dim BB As Integer
n = 10
ReDim A(n, 2) '5 unikke
A(1, 1) = 1
A(2, 1) = 7
A(3, 1) = 2
A(4, 1) = 6
A(5, 1) = 3
A(6, 1) = 5
A(7, 1) = 1
A(8, 1) = 1
A(9, 1) = 1
A(10, 1) = 4
A(1, 2) = 1
A(2, 2) = 7
A(3, 2) = 2
A(4, 2) = 6
A(5, 2) = 3
A(6, 2) = 5
A(7, 2) = 1
A(8, 2) = 1
A(9, 2) = 1
A(10, 2) = 4
BB = Unikke(A) 'Unikke is the second function that provides the amount of unique values
Dim FF() As Integer
ReDim FF(BB, 1)
FF = HvilkeUnikke(A) 'the second function, which has the output of an array a.k.a the problem
End Sub
This is the function:
Public Function HvilkeUnikke(ByRef A() As Integer) As Integer
Dim L() As Integer
Dim B As Integer
Dim i As Integer
Dim i2 As Integer
Dim A2() As String
Dim BB As Integer
Dim C() As Integer
BB = Unikke(A)
ReDim C(UBound(A), 2)
ReDim A2(BB, 1)
ReDim L(BB, 1)
For i = 1 To UBound(A)
C(i, 1) = A(i, 1)
C(i, 2) = A(i, 2)
Next
For i = 1 To UBound(C)
B = 0
For i2 = 1 To UBound(C)
If C(i, 1) = C(i2, 2) Then
B = B + 1
If B > 1 Then
C(i2, 2) = 0
End If
End If
Next i2
Next i
B = 0
For i2 = 1 To UBound(C)
If C(i2, 2) > 0 Then
B = B + 1
L(B, 1) = C(i2, 2)
End If
Next i2
HvilkeUnikke = L
End Function
The results are as expected, but they should be in a variable inside my sub.
(The solution)
Sub test()
Dim FF() As Integer
Dim i As Integer
Dim A() As Integer
Dim n As Integer
Dim BB As Integer
n = 10
ReDim A(n, 2) '7 unikke
A(1, 1) = 1
A(2, 1) = 7
A(3, 1) = 2
A(4, 1) = 6
A(5, 1) = 3
A(6, 1) = 5
A(7, 1) = 1
A(8, 1) = 1
A(9, 1) = 1
A(10, 1) = 4
A(1, 2) = 1
A(2, 2) = 7
A(3, 2) = 2
A(4, 2) = 6
A(5, 2) = 3
A(6, 2) = 5
A(7, 2) = 1
A(8, 2) = 1
A(9, 2) = 1
A(10, 2) = 4
BB = Unikke(A)
ReDim FF(BB)
FF = HvilkeUnikke(A)
'Testing on the worksheet
For i = 1 To BB
Cells(i, 1) = FF(i)
Next
End Sub
And the function
Public Function HvilkeUnikke(ByRef A() As Integer) As Integer()
Dim L() As Integer
Dim B As Integer
Dim i As Integer
Dim i2 As Integer
Dim A2() As String
Dim BB As Integer
Dim C() As Integer
BB = Unikke(A)
ReDim C(UBound(A), 2)
ReDim A2(BB, 1)
ReDim L(BB)
For i = 1 To UBound(A)
C(i, 1) = A(i, 1)
C(i, 2) = A(i, 2)
Next
For i = 1 To UBound(C)
B = 0
For i2 = 1 To UBound(C)
If C(i, 1) = C(i2, 2) Then
B = B + 1
If B > 1 Then
C(i2, 2) = 0
End If
End If
Next i2
Next i
B = 0
For i2 = 1 To UBound(C)
If C(i2, 2) > 0 Then
B = B + 1
L(B) = C(i2, 2)
End If
Next i2
HvilkeUnikke = L
End Function
I want to create a piece of code that lets me assign a value from a array to another array, which are of different lengths. This is what I have so far.
A(1) = 0
A(2) = 0
A(3) = 6
A(4) = 5
A(5) = 7
n = 0
For i = 1 To 5
If A(i) <> 0 Then
n = n + 1
End If
Next i
ReDim B(1 To n) As Integer
For j = 1 To n
For i = 1 To 5
If A(i) <> 0 Then
B(j) = A(i)
End If
Next i
Next j
MsgBox B(2)
At the moment this returns 7 whereas it should return 5, all values in B are 7. How can I get this code to run?
The fact that you have nested loops should alarm you: this would be executed n * 5 times, which cannot be correct.
Change the second part so it only uses one loop, like this:
ReDim B(1 To n) As Integer
j = 1
For i = 1 To UBound(A)
If A(i) <> 0 Then
B(j) = A(i)
j = j + 1
End If
Next i
Note also that using UBound instead of 5 makes your code more generic. Note also that this loop is very similar to the loop that calculates n. The only difference is that you assign to B(j).
You could in fact combine it with the first loop, if you would re-dimension B twice, the second time with Preserve:
ReDim B(1 To UBound(A)) As Integer
n = 0
For i = 1 To UBound(A)
If A(i) <> 0 Then
n = n + 1
B(n) = A(i)
End If
Next i
' Shorten the array without losing data:
ReDim Preserve B(1 To n)
You are going to have to check B for the first empty array element and exit the loop so you do not continue to write.
Dim A() As Variant, B() As Variant
Dim i As Long, j As Long, n As Long
A = Array(0, 0, 6, 5, 7) '<~~ 0 to 4, not 1 to 5
n = 0
For i = LBound(A) To UBound(A)
If A(i) <> 0 Then
n = n + 1
End If
Next i
ReDim B(1 To n) '<~~ 1 to 3
For i = LBound(A) To UBound(A)
If A(i) <> 0 Then
For j = LBound(B) To UBound(B)
If IsEmpty(B(j)) Then
B(j) = A(i) '<~~ assigned a value; exit loop
Exit For
End If
Next j
End If
Next i
For j = LBound(B) To UBound(B)
Debug.Print B(j)
Next j
Given that arrays can be either zero-based or one-based, I prefer to use the LBound and UBound functions to define their scope.