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
Related
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 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
I've been using =ROWS(my_range)*COLUMNS(my_range) to count the total number of cells within a single column.
I'm now trying to count the total number of cells across a range that contains (unavoidably) merged cells and I'm getting a #REF error using the above formula.
I've also tried: =COUNTA(my_range) & "/" & COUNTA(my_range) + COUNTBLANK(my_range) which is giving me a #VALUE! error.
In my last attempted I hoped that =ROWS(my_range) might work as I've only got merged columns, not merged rows. However this is giving me a #REF error. `
All I need is the total number of cells that exists within my_range
Thank you
So using merged cells make it really annoying to work with a lot of formulas, so I wrote a VBA solution using Arrays:
First this function will go through the range and each time it recognizes a merged cell, the code will add the cells to an Array.
Later when the loop comes to a cell marked as "merged" (= is in the array), the count will skip it (thanks to this topic: Check if a value is in an array or not with Excel VBA).
Option Explicit
Function CountCells(RA As Range) As Long
Application.Volatile
Dim i As Long
Dim a As Long
Dim i2 As Long
Dim a2 As Long
Dim RowCount As Long
Dim ColCount As Long
Dim k As Long
Dim R1 As Long
Dim R2 As Long
Dim C1 As Long
Dim C2 As Long
ReDim iArray(1 To 1) As Variant
R1 = RA.Row
R2 = R1 + RA.Rows.Count - 1
C1 = RA.Column
C2 = C1 + RA.Columns.Count - 1
k = 0
For i = R1 To R2
For a = C1 To C2
If IsInArray(Cells(i, a).Address, iArray) Then
GoTo next_a
End If
ColCount = Cells(i, a).MergeArea.Columns.Count
RowCount = Cells(i, a).MergeArea.Rows.Count
If RowCount > 1 Or ColCount > 1 Then
k = k + RowCount * ColCount - 1
For i2 = i To i + RowCount - 1
For a2 = a To a + ColCount - 1
iArray(UBound(iArray)) = Cells(i2, a2).Address
ReDim Preserve iArray(1 To UBound(iArray) + 1) As Variant
Next a2
Next i2
End If
next_a:
Next a
Next i
CountCells = (R2 + 1 - R1) * (C2 + 1 - C1) - k
End Function
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Application.Volatile
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Then you just need to use this function like this in your sheet:
=countcells(my_range)
or any other range instead of your range named my_range
Note: With Application.Volatile the function updates automatically, but only when you update the sheet with numbers but just not directly when you merge or unmerge cells.
I have 10 cells A1:A10 and I have 3 values (5, 4, 8)
I want to distribute them randomly in A1:A10 so only 3 of 10 cells will be filled and the other 7 will be blank
How to make it?
for example:
please see the screenshot
please see the other screenshot
You can also achieve this with regular Excel formulas and here is how you do it:
Column A: Enter those three values you mentioned (5, 4, 8) and other 7 cells with one empty space.
Column B: Fill out this formula =RAND()
Column C: Fill out this fomrula =INDEX($A$2:$A$11,RANK(B2,$B$2:$B$11))
What this does is to return non-duplicate random list by the ranking. And therefore, you have to have other 7 cells with an empty space.
Please also note that I have a header row so you may need to tweak the formula a little bit to fit your need. Try and let me know.
If you are trying to automate you can tie the following VBA to a command button.
I have included a link to how you can also randomize the array holding the numbers 4,5,8. Assumes you are running in a sheet called TargetSheet.
Option Explicit
Sub AssignNumbers()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim x As Long, i As Long
Dim Arr()
Set wb = ThisWorkbook
Set ws = wb.Sheets("TargetSheet")
Set rng = ws.[A1:A10]
Arr = Array(4, 5, 8) 'You can randomize this array as follows (somewhat irrelevant as assignment is random): _
http://www.cpearson.com/excel/ShuffleArray.aspx
rng.ClearContents
For i = 0 To 2
'Loop until we find an empty cell to place the value in
Do
x = Application.WorksheetFunction.RandBetween(1, 10)
'Exit the loop as soon as we find a place to put the value
If IsEmpty(rng.Cells(x, 1).Value) Then Exit Do
Loop
'Have found an empty cell - we can now set the value
rng.Cells(x, 1) = arr(i)
Next i
End Sub
Make a list (or array) of number from 1 to 10
Randomise the order of the list
Plot the numbers in the randomised order in A1:10*
Profit!
*Any numbers which arent 4, 5 or 8, can be translated to a blank cell
Creating and randomising an array and printing it to A1:10
Sub RunShuffle()
Dim i As Integer
Dim j As Integer
Dim MyArray(9) As Variant
'Fill the array with numbers 1 to 10
For i = LBound(MyArray) To UBound(MyArray)
MyArray(i) = i + 1
Next i
'Randomise the order of the array
ShuffleArrayInPlace MyArray
'Print the randomised array to A1:10
For j = LBound(MyArray) To UBound(MyArray)
Sheets(1).Cells(j + 1, "A").Value = MyArray(j)
If MyArray(j) <> 4 And MyArray(j) <> 5 And MyArray(j) <> 8 Then
Sheets(1).Cells(j + 1, "A").Value = ""
End If
Next j
End Sub
'This Sub shuffles the array given as input
Sub ShuffleArrayInPlace(InArray() As Variant)
Dim n As Long
Dim Temp As Variant
Dim j As Long
Randomize
For n = LBound(InArray) To UBound(InArray)
j = CLng(((UBound(InArray) - n) * Rnd) + n)
If n <> j Then
Temp = InArray(n)
InArray(n) = InArray(j)
InArray(j) = Temp
End If
Next n
End Sub
Source for randomisation code: CPearson.com
I saw array() = range().value in an example and I'm trying to understand how it works.
Sub test()
Dim arr() As Variant
arr() = Range("E5:E7").Value
For i = 0 To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
First, above code is giving me subscript out of range error. How come ? Second, what part of the documentation would let me know how array() = range().value would play out without testing it ? My hypothesis is that it will go through the cells from the top left to the bottom right and add them to the array. How can I confirm that though ?
I see two issues with your code. The first is that you start i at 0, but arrays in Excel begin at index 1. Instead of For i = 0 you can use For i = LBound(arr) like you use UBound(arr) or just start it at 1.
Second, and more importantly, an array of cells has both columns and rows. When you read a range into a variant array, you get a two-dimensional result (rows and columns) and not a one-dimensional result as you seem to be expecting.
Try this:
Sub test()
Dim arr() As Variant
Dim i As Long, j As Long
arr() = Range("E5:E7").Value
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
Debug.Print arr(i, j)
Next j
Next i
End Sub
If you want to get just the values of the cells into a one dimensional array, you can do that by using the Transpose function, like this:
arr() = Application.WorksheetFunction.Transpose(Range("E5:E7").Value)
If you do this, the array is now one-dimensional and you can iterate through it like you were trying to.
arr() = Application.WorksheetFunction.Transpose(Range("E5:E7").Value)
For i = 1 To UBound(arr)
Debug.Print arr(i)
Next i
This is a good read for you: http://www.cpearson.com/excel/ArraysAndRanges.aspx
The reason you're getting "out of range" is because it returns a 2 dimensional array.
Your line of code For i = 0 To UBound(arr) should be For i = 1 To UBound(arr,1)
Also, the array starts at 1, so don't use the 0 For i = 1 to UBound(arr, 1)
Your corrected code would be:
Sub Test()
Dim arr() as Variant
arr = Range("E5:E7")
For i = 1 To UBound(arr, 1)
MsgBox (arr(i, 1))
Next i
End Sub
It's basically loading the cell values of E5 - E7 into an array. But it is going to be two dimensional. So you will need Debug.Print arr(i, 1)
Sub test()
Dim arr() As Variant
arr() = Range("E5:E7").Value
For i = 1 To UBound(arr)
Debug.Print arr(i, 1)
Next i
End Sub