I'm VERY new to Excel VBA. I want to write a function that offsets the cells in the current vector (the range selected by the user) by an amount also specified by the user.
The cells must be moved up out of the array by "n", and must then be displayed at the bottom of the same array after the remaining cells have moved up to take the place of the cells shifted up and out of the array.
Any advice will be greatly appreciated, the current code I wrote is not working and I know too little to help myself.
Many thanks!
Function ShiftVector(rng As Range, n As Integer)
'User selects a vector and inputs an integer.
'The vector must be sorted upwards by the amount equal to the entered integer
Dim i As Integer, rw As Integer, temp As Variant
rw = rng.rows.Count
ReDim b(1 To rw) As Variant
ReDim temp(1 To n) As Variant
b = rng
For i = 1 To n
temp = b(i)
'move the data in cells i=1 to n to the temporary array
Next i
b(i) = rng.Offset(-n, 0)
'move the cells in array b up by n
For i = rw - n To nr
b(i) = temp
i = i + 1
'I'm not sure if this is correct: I want to replace the top shifted cells
'back into the bottom of array b
Next i
ShiftVector4 = b
'The function must output the newly assembled array b where
'the top cells that were moved up n-spaces are now wrapped
'around and are shown at the bottom of the array b
End Function
Something like this should work:
Sub Tester()
ShiftUp Range("B4:C13"), 3
End Sub
Sub ShiftUp(rng As Range, numRows As Long)
Dim tmp
With rng
tmp = .Rows(1).Resize(numRows).Value
.Rows(1).Resize(.Rows.Count - numRows).Value = _
.Rows(numRows + 1).Resize(.Rows.Count - numRows).Value
.Rows((.Rows.Count - numRows) + 1).Resize(numRows).Value = tmp
End With
End Sub
As a UDF:
Function ShiftUp(rng As Range, numRows As Long)
Dim d, dOut, r As Long, c As Long, rMod As Long, rTot As Long
Dim break As Long
d = rng.Value
dOut = rng.Value 'as a shortcut to creating an empty array....
rTot = UBound(d, 1)
break = rTot - numRows
For r = 1 To rTot
For c = 1 To UBound(d, 2)
'figure out which input row to use...
rMod = IIf(r <= break, r + numRows, -(break - r))
dOut(r, c) = d(rMod, c)
Next c
Next r
ShiftUp = dOut
End Function
Note this is an array formula, so you will need to select a range the same size as the input range and enter the formula using CtrlShiftEnter
Related
I'm working on this project and I need to create a function in VBA in order to store a formula and return the result in excel using the index function. My code is as below and i created just a simple dummy function for testing purposes. In excel I believe the function should be =INDEX(NewArray,,1)? Any help on this would be greatly appreciated Thanks
Public Function NewArray(a As Integer, b As Integer) As Long()
Dim arr() As Long
ReDim arr(1 To 10, 1 To 5) As Long
Dim row As Integer
Dim col As Integer
For row = 1 To 5
arr(row, 1) = (row + 1)
Next row
NewArray = arr(a, b)
End Function
Using a 'UDF Array' with INDEX
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a 2D one-based array with 'a' rows and 'b' columns.
' populated by the product of rows and columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function NewArray(ByVal a As Long, ByVal b As Long) As Long()
Dim arr() As Long: ReDim arr(1 To a, 1 To b)
Dim r As Long
Dim c As Long
For r = 1 To a ' loop (iterate) through rows
For c = 1 To b ' loop (iterate) through columns
arr(r, c) = r * c ' e.g. product of the current row and column
Next c
Next r
NewArray = arr ' don't forget to return the result
End Function
5 rows, 7 columns
In VBA, return the elements of the array in the Immediate window (Ctrl+G).
Sub NewArrayTEST()
Dim arr() As Long: arr = NewArray(5, 7)
Dim r As Long
Dim c As Long
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
Debug.Print r, c, arr(r, c)
Next c
Next r
End Sub
In Excel, you can return the element at the intersection of the 2nd row
and the 3rd column using the INDEX function:
=INDEX(NewArray(5,7),2,3)
The result is 6 since we added the product 2*3.
For context of the code here. I have combined several of these 96 cell ranges into one larger range composed on n smaller ranges. Reason for doing this is to make it (more) scalable.
I have a range of data I want to break them up into n ranges/chunks and run my function on each (function below, shout out to #Tim Williams for the function) and combine the outputs all into a column. One solution I don't really like but I could do is to simply run the function on each n chunks/ranges and manually combine them, however, that's not really optimal for what I need. I am still pretty new to VBA, any ideas would be much appreciated!
The function I am using is as follows. Note my comment within the function:
Sub Tester()
Dim rng As Range, arr
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3:N66")
Set plates = Combows.Range("A2")
ArrayToCell BlockToList(rng, plates), Poolws.Range("A2") 'read by column
ArrayToCell BlockToList(rng, plates, False), Poolws.Range("F2") 'read by column
End Sub
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For m = 1 To dc
' I think something in the following lines needs to change.
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = 1 To dr / platenum
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
BlockToList = arrOut
End Function
'Utility method for populating an array to a range
Sub ArrayToCell(arr, rngDest As Range)
rngDest.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Here's how I'd approach that:
Sub Tester()
Const PLT_ROWS As Long = 8
Const PLT_COLS As Long = 12
Dim rng As Range, arr, rngOut As Range
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3").Resize(PLT_ROWS, PLT_COLS)
Set rngOut = Poolws.Range("F2")
Do While Application.CountA(rng) > 0
ArrayToCell BlockToList(rng, False), rngOut 'by column or by row?
Set rng = rng.Offset(rng.Rows.Count, 0) 'next input block
Set rngOut = rngOut.Offset(0, 1) 'output next column over?
'Set rngOut = rngOut.Offset(rng.Cells.Count, 0) '...or append to previous?
Loop
End Sub
Rest of code from previous question is unchanged - in order to keep your code as modular as possible it's best to avoid special-casing your "core" methods where you can.
If you're dealing with multi-plate output files from an instrument, ideally you want to be reading directly from those files (typically after opening them in Excel so you don't need to do the parsing) with no intermediate copy/paste/consolidate steps.
I found a solution (for anyone who cares):
I added a loop that breaks the range/array/chunk into sections (in this case I know they are always 8 "tall"). I'm sure someone could have a better solution, but this one worked for me! Code as follows:
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, o As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For o = 0 To platenum * 8
If ((o * 8) + 8) <= dr Then
For m = 1 To dc
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = ((o * 8) + 1) To ((o * 8) + 8)
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
Next o
End If
BlockToList = arrOut
End Function
I have an array of numbers in an excel spreadsheet which I am trying to sort (all numbers >60) using a user defined vba function and i want to return the result as a range in the same excel sheet.
I am getting a value error when i run this function in excel.I am not too sure where this error is coming from as I a new to VBA.I would really appreciate some guidance in resolving this issue.
Array Excel
Column A
200
50
23
789
Function trial(number As Range)
Dim cell As Range
Dim savearray() As Variant
Dim d As Long
For Each cell In Range("a3:a6").Cells
If cell.Value > 60 Then
d = d + 1
ReDim Preserve savearray(1 To d)
savearray(1, d) = cell.Value
trial = savearray
End If
Next cell
End Function
There is a bit of work to do on your Sub. However, to help you, below is a way to dynamically build an array:
d = 0
For Each cell In Range("A3:A1000")
If cell.Value > 60 Then
If d = 0 Then
ReDim savearray(0 To 0)
Else
ReDim Preserve savearray(0 To UBound(savearray) + 1)
End If
savearray(d) = cell.Value
d = d + 1
End If
Next cell
I feel like you might want to rather return a sorted array and only then, cast results to a Range
First we create a Function to sort our array
Private Function BubbleSort(ByRef from() As Variant) As Variant()
Dim i As Integer, j As Integer
Dim temp As Variant
For i = LBound(from) To UBound(from) - 1
For j = i + 1 To UBound(from)
If from(i) < from(j) Then
temp = from(j)
from(j) = from(i)
from(i) = temp
End If
Next j
Next i
BubbleSort = from ' returns sorted array
End Function
Then we create a simple "Range replacer" procedure
Private Sub replace_with_sorted(ByVal which As Range)
Dim arr() As Variant
arr = Application.Transpose(which)
arr = BubbleSort(arr)
which = Application.Transpose(arr)
End Sub
So the invokation would look the following way:
Private Sub test()
replace_with_sorted Range("A1:A4")
End Sub
This of course produces the expected result:
EDIT: Just noticed you want to sort only values larger than 60.
In that case, simply fill an array with values larger than 60 and use the same application.
Private Sub test()
Dim arr() as Variant: arr = Application.Transpose(Range("A1:A4"))
Dim above60() as Variant
Dim i as Integer, j as Integer: j = 0
For i = LBound(arr) To UBound(arr)
If arr(i) > 60 Then
ReDim Preserve above60(j)
above60(j) = arr(i)
j = j + 1
End If
Next i
ReDim arr()
arr = BubbleSort(above60)
' returns sorted array, do whatever u want with it _
(place it in whatever range u want, not defined in ur question)
End Sub
I'm still trying to figure out VBA and I have a query on sorting
I have a function call MatrixSort(matrix) that takes in a n1 x n2 matrix.
Is there any sorting function that VBA has that enables me to sort the matrix by count as seen below?
Inputting the box into Matrix Sort and getting the output below:
Would appreciate if anyone can enlighten me on this
Thanks you very much!
Edit:
Thanks to pEH for your code and logic. I have came up with the function based on your idea!
Although the code might not be efficient, I realized that there isn't an easy way to do CountA since the function will substitute empty cells as 0, as such I had to manually input "" and have the counter to ignore it.
'Sorts the Matrix into Decending Count Order
'Key Idea: Calculate count in each column and saves into ArrCount
'Then use Max(ArrCount) to find the max row count
'Use Match to get the column number with the max row count, then input this to first column under MatrixOut
'Kill the count that was copied under ArrCount(iMax) = -1 so that the next maximum count can be found
'Thanks to pEH from Stackoverflow for helping out
Function MatrixSort(matrix)
Dim MatrixTemp As Variant
Dim max_row As Integer
Dim max_col As Integer
Dim p As Object
Dim i As Integer
Dim j As Integer
Dim counter As Double 'Counts the number of filled range in matrix
Dim iMax As Integer 'Stores the max count for sorting phase
MatrixTemp = matrix
'To preserve empty cells as empty instead of 0
max_row = UBound(MatrixTemp, 1)
max_col = UBound(MatrixTemp, 2)
ReDim MatrixIn(1 To max_row, 1 To max_col)
For i = 1 To UBound(MatrixTemp, 1)
For j = 1 To UBound(MatrixTemp, 2)
If MatrixTemp(i, j) = "" Then
MatrixIn(i, j) = ""
Else
MatrixIn(i, j) = MatrixTemp(i, j)
End If
Next j
Next i
Set p = Application.WorksheetFunction
'Counting of Each Columns
ReDim ArrCount(1 To max_col) 'Counts filled rows in each column
ReDim column_extract(1 To max_row) 'For CountA to work by counting each column individually
For j = 1 To max_col
For i = 1 To max_row
If MatrixIn(i, j) <> "" Then
counter = counter + 1
End If
Next i
ArrCount(j) = counter 'Stores the total count
counter = 0 'Resets the counter before another loop
Next j
'Creation of Final Output Matrix
ReDim MatrixOut(1 To max_row, 1 To max_col) 'For the Final Output
'Column Sort
For j = 1 To max_col
iMax = p.Match(p.Max(ArrCount), ArrCount, False)
For i = 1 To max_row
MatrixOut(i, j) = MatrixIn(i, iMax)
Next i
ArrCount(iMax) = -1
Next j
MatrixSort = MatrixOut
End Function
Imagine the following data:
To sort it by the count of filled rows in each column you just need to calculate that count .CountA(RngIn.Columns(iCol)) for each column and save the results into an array ArrCount.
Then you can use .Max(ArrCount) to find the maximum row count and .Match to get the column number which is maximum. This is your first column so write it to the destination RngOut. Now we just need to kill the count that was already copied ArrCount(iMax) = -1 so the next maximum can be found and copied to the next destination column … and so on …
Option Explicit
Public Sub MatrixSortColumnsByRowCount()
'input range
Dim RngIn As Range
Set RngIn = Worksheets("Sheet1").Range("B2:F8")
'output range
Dim RngOut As Range
Set RngOut = Worksheets("Sheet1").Range("B12:F18")
'count filled rows in each column
ReDim ArrCount(1 To RngIn.Columns.Count) As Long
Dim iCol As Long
For iCol = 1 To RngIn.Columns.Count
ArrCount(iCol) = Application.WorksheetFunction.CountA(RngIn.Columns(iCol))
Next iCol
'sort columns
Dim iMax As Long
For iCol = 1 To RngIn.Columns.Count
iMax = Application.WorksheetFunction.Match(Application.WorksheetFunction.Max(ArrCount), ArrCount, False)
RngOut.Columns(iCol).Value = RngIn.Columns(iMax).Value
ArrCount(iMax) = -1
Next iCol
End Sub
The output then will be …
I can't get around the below problem and any help would be greatly appreciated
I have a 2 dimensional array that looks like the below;
PFAllArr
I want to create a new array (PFArr) from this, but without the rows where deleted = "yes". I could make this new array the same size as the original one, just leaving blank rows where i have removed data, but this array will be used in numerous loops down the code so i want to make it as compact as possible.
With the below code i have tried to get the number of elements where deleted = 0 ( which i want to keep)... using a loop.
Then redim the new array to this size.
Then it should assign the relevant elements from the old array to the new array with the second loop. However it is not assigning the elements into the array as expected, it seems to be looping through fine, just not adding the new elements in. Any ideas?
Sub AddSelectDataFromBigArrayToSmallOne()
Dim PFAllArr As Variant
Dim PFArr As Variant
Dim c1, i1, c2, i2 As Long
PFAllArr = Sheets("PF File Simple").Range("A2").CurrentRegion.Value
'get number of elements i want to transfer to new array
c1 = 1
For i1 = LBound(PFAllArr) To UBound(PFAllArr)
If PFAllArr(i1, 2) = 0 Then
c1 = c1 + 1
End If
Next i1
'Make new array this size
ReDim PFArr(LBound(PFAllArr) To c1, 1 To 4)
'Assign elements from old array nto new one
c2 = 1
For i2 = LBound(PFAllArr) To UBound(PFAllArr)
If PFAllArr(i2, 2) = 0 Then
PFArr(c2, 3) = PFAllArr(i2, 3)
PFArr(c2, 4) = PFAllArr(i2, 4)
c2 = c2 + 1
End If
Debug.Print c2, PFArr(c2, 3), PFArr(c2, 4)
Next i2
End Sub
Perhaps something like this?
Sub tgr()
Dim aTemp As Variant
Dim aData As Variant
Dim iyTemp As Long
Dim iyData As Long
Dim ix As Long
With ActiveWorkbook.Sheets("PF File Simple").Range("A2").CurrentRegion
aTemp = .Value
ReDim aData(1 To WorksheetFunction.CountIf(.Resize(, 1).Offset(, 1), 0), 1 To .Columns.Count)
End With
For iyTemp = 1 To UBound(aTemp, 1)
If aTemp(iyTemp, 2) = 0 Then
iyData = iyData + 1
For ix = 1 To UBound(aTemp, 2)
aData(iyData, ix) = aTemp(iyTemp, ix)
Next ix
End If
Next iyTemp
'aData is now populated with only values where the second column is 0
End Sub
Two things
You will need to change c1 to start at 0 instead of 1. If you declare your variable type right, you can just not set the initial value. Long type variable will default to 0 unless stated otherwise
Your variable block Dim c1, i1, c2, i2 As Long is not working how you may think it is. You are actually declaring i2 as Long and the rest of your variables are being pushed into Variant type variable. This part is less important, but chives well on this topic: you can also just use Dim PFAllArr, PFArr and these will default to Variant
Thus, you can start your code like so (removed your c1 set, and updated lines to declare variables as intended):
Sub AddSelectDataFromBigArrayToSmallOne()
Dim PFAllArr, PFArr
Dim c1 as Long, i1 as Long, c2 as Long, i2 As Long
PFAllArr = Sheets("PF File Simple").Range("A2").CurrentRegion.Value
For i1 = LBound(PFAllArr) To UBound(PFAllArr)
If PFAllArr(i1, 2) = 0 Then
c1 = c1 + 1
End If
Next i1
IMO, #tigeravatar's solution looks cleaner. Regardless of which code you end up using, it is always nice to see why yours didn't work
Using Application.Index
You can use the advanced filtering possibilities of the Index function:
Main procedure
Sub DelRows()
Dim PFAllArr, PFArr
' [1a] create 2-dim data field array (1-based)
PFAllArr = ThisWorkbook.Worksheets("PF File Simple").Range("A2").CurrentRegion.Value2
' [1b] filter out rows to be deleted
PFArr = Application.Transpose(Application.Index(PFAllArr, getAr(PFAllArr, 2), Evaluate("row(1:" & UBound(PFAllArr, 2) & ")")))
End Sub
Helper function getAr()
Function getAr(v, ByVal colNo&) As Variant()
' Purpose: collect row numbers not to be deleted (criteria <> "YES" in 2nd column)
' Note: called by above procedure DelRows
Dim ar, i&, n&
ReDim ar(0 To UBound(v) - 1)
For i = 1 To UBound(v)
If UCase$(v(i, colNo)) <> "YES" Then
ar(n) = i: n = n + 1
End If
Next i
ReDim Preserve ar(0 To n - 1): getAr = ar
End Function