I am trying to create an array of size 50 in vba of random numbers between 0 and 20 then extracting the numbers that repeat in that array into another array.
Sub Problem10()
Dim numbers() As Double, odd() As Double, even() As Double, five() As Double, repeating() As Double, x As Integer, i As Integer, sOdd As Integer, sEven As Integer, sFive As Integer, sNumbers As Integer, sRepeating As Integer, y As Integer, listed As Boolean
sRepeating = 0
sNumbers = 50
For i = 1 To sNumbers
ReDim Preserve numbers(i)
numbers(i) = Int(20 * rnd)
'find repeating numbers
For x = 1 To i
If numbers(x) = numbers(i) And i <> x Then
'check if there are any repeated numbers already
If sRepeating > 0 And listed = False Then
For y = 1 To sRepeating
'check if the number is already listed as a repeated number
If numbers(i) = repeating(y) Then
listed = True
Else
sRepeating = sRepeating + 1
ReDim Preserve repeating(sRepeating)
repeating(sRepeating) = numbers(i)
Cells(sRepeating + 1, 4).Value = repeating(sRepeating)
listed = True
End If
Next y
End If
End If
Next x
Cells(i + 1, 5).Value = numbers(i)
Next i
End Sub
I am able to create the array with random numbers (numbers()) and then extract new arrays with even, odd numbers and multiples of 5. However, I dont know how to extract only repeating numbers.
Right now, this only finds the first repeating number and nothing else.
Consider the below example:
Option Explicit
Sub Test()
Dim i
Dim numbers(0 To 49)
Dim repeating()
Dim q
' Fill array with random numers
Randomize
For i = 0 To 49
numbers(i) = Int(20 * Rnd)
Next
' Filter repeating elements
With CreateObject("Scripting.Dictionary")
' Count each number qty
For i = 0 To 49
.Item(numbers(i)) = .Item(numbers(i)) + 1
Next
' Remove non-repeating
For Each q In .Keys()
If .Item(q) = 1 Then .Remove q
Next
' Retrieve array
repeating = .Keys()
End With
Debug.Print Join(numbers)
Debug.Print Join(repeating)
End Sub
Related
I am trying to create a function that finds the mean of the last d days from an array. My array is a time series with dates as col1 and prices as col2.
I want my function to be to allow the user to select the range, enter the number of days in past he wants the mean, and a Boolean whether the data is ascending or descending. if the number of elements in the series doesn't match d, example mean of 32 + "" then the function returns 0.
the Problem i am having is when i want to use the drag down in excel to fill the rest of the columns, the function doesn't work. for example for the sorted array; it takes mean of 56 + 34, then using drag down in excel the second cell should be the mean of 34 + 22 except it returns 0 and so on..
Function meanby(x As Range, d As Integer, sortarr As Boolean) As Double
Dim arr() As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim total As Double
Dim n As Integer
Dim temp As Variant
Dim arr2 As Variant
arr = rgntoarr(x)
n = x.Rows.count
If sortarr = False Then
For i = 1 To n / 2
temp = arr(i, 2)
arr(i, 2) = arr(n - i + 1, 2)
arr(n - i + 1, 2) = temp
Next i
End If
arr2 = arr
For j = 1 To d
total = total + arr2(j, 2)
If arr2(j, 2) = "" Then
Exit For
End If
i = i + 1
count = count + 1
Next j
If count < d Then
meanby = 0
Else
meanby = total / count
End If
End Function
I am an accountant and I need to match every customer payment against the outstanding invoices every day, I found a very nice and elegant VBA code published by Michael Schwimmer in this website. https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem
The code works perfect, it can automatically calculate and list the results that are added up to a specific sum. However, I would like the VBA code to returns the invoice numbers as well. The code passed an array of the values to a function for calculation and then returns the possible solution to Column E, I don't have knowledge in array so don't know how to pass the array of the invoice numbers to the function and return the results. Could anyone help? The code is as below, you can also download the excel workbook from the link I provided. Thanks in advance!
Private Sub cmbCalculate_Click()
Dim dGoal As Double
Dim dTolerance As Double
Dim dAmounts() As Double
Dim vResult As Variant
Dim m As Long
Dim n As Long
With Me
dGoal = .Range("B2")
dTolerance = .Range("C2")
ReDim dAmounts(1 To 100)
For m = 2 To 101
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
dAmounts(m - 1) = .Cells(m, 1)
Else
ReDim Preserve dAmounts(1 To m - 1)
Exit For
End If
Next
ReDim Preserve dAmounts(1 To UBound(dAmounts) - 1)
vResult = Combinations(dAmounts, dGoal, dTolerance)
Application.ScreenUpdating = False
.Range("D3:D65536").ClearContents
.Range(.Cells(3, 4), .Cells(UBound(vResult) + 3, 4)) = vResult
Application.ScreenUpdating = True
End With
End Sub
Function Combinations( _
Elements As Variant, _
Goal As Double, _
Optional Tolerance As Double, _
Optional SoFar As Variant, _
Optional Position As Long) As Variant
Dim i As Long
Dim k As Long
Dim dCompare As Double
Dim dDummy As Double
Dim vDummy As Variant
Dim vResult As Variant
If Not IsMissing(SoFar) Then
'Sum of elements so far
For Each vDummy In SoFar
dCompare = dCompare + vDummy
Next
Else
'Start elements sorted by amount
For i = 1 To UBound(Elements)
For k = i + 1 To UBound(Elements)
If Elements(k) < Elements(i) Then
dDummy = Elements(i)
Elements(i) = Elements(k)
Elements(k) = dDummy
End If
Next
Next
Set SoFar = New Collection
End If
If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)
'Add current element
SoFar.Add Elements(i)
dCompare = dCompare + Elements(i)
If Abs(Goal - dCompare) < (0.001 + Tolerance) Then
'Goal achieved
k = 0
ReDim vResult(0 To SoFar.Count - 1, 0)
For Each vDummy In SoFar
vResult(k, 0) = vDummy
k = k + 1
Next
Combinations = vResult
Exit For
ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
'Enough room for another element
'Call recursively starting with next higher amount
vResult = Combinations(Elements, Goal, Tolerance, SoFar, i + 1)
If IsArray(vResult) Then
Combinations = vResult
Exit For
Else
SoFar.Remove SoFar.Count
dCompare = dCompare - Elements(i)
End If
Else
'Amount too high
SoFar.Remove SoFar.Count
Exit For
End If
Next 'Try next higher amount
End Function
You could probably get the invoice numbers simply with a VLOOKUP but here is a VBA solution. I have changed the values in the Sofar collection from invoice amounts to the index number for that amount. That index number then gives the corresponding invoice number from a new array InvNo.
Update - Sorted by due date
Sub cmbCalculate_Click()
Dim ws As Worksheet, dAmounts() As Double, sInvno() As String
Dim i As Long, dSum As Double
Dim dtDue() As Date
Set ws = Me
i = ws.Cells(Rows.Count, "A").End(xlUp).Row
ReDim dAmounts(1 To i - 1)
ReDim sInvno(1 To i - 1)
ReDim dtDue(1 To i - 1)
' fill array
For i = 1 To UBound(dAmounts)
dAmounts(i) = ws.Cells(i + 1, "A")
sInvno(i) = ws.Cells(i + 1, "B")
dtDue(i) = ws.Cells(i + 1, "C")
dSum = dSum + dAmounts(i)
Next
' sort array
Call BubbleSort(dAmounts, sInvno, dtDue)
Dim n: For n = LBound(dAmounts) To UBound(dAmounts): Debug.Print n, dAmounts(n), sInvno(n), dtDue(n): Next
Dim dGoal As Double, dTolerance As Double, vResult As Variant
dGoal = ws.Range("D2")
dTolerance = ws.Range("E2")
' check possible
If dGoal > dSum Then
MsgBox "Error : Total for Invoices " & Format(dSum, "#,##0.00") & _
" is less than Goal " & Format(dGoal, "#,##0.00")
Else
' solve and write to sheet
vResult = Combinations2(dAmounts, sInvno, dtDue, dGoal, dTolerance)
If IsArray(vResult) Then
With ws
.Range("F3:H" & Rows.Count).ClearContents
.Range("F3").Resize(UBound(vResult), 3) = vResult
End With
MsgBox "Done"
Else
MsgBox "Cannot find suitable combination", vbCritical
End If
End If
End Sub
Function Combinations2( _
Elements As Variant, _
Invno As Variant, _
Due As Variant, _
Goal As Double, _
Optional Tolerance As Double, _
Optional SoFar As Variant, _
Optional Position As Long) As Variant
Dim i As Long, n As Long, dCompare As Double
' summate so far
If IsMissing(SoFar) Then
Set SoFar = New Collection
Else
For i = 1 To SoFar.Count
dCompare = dCompare + Elements(SoFar(i))
Next
End If
If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)
SoFar.Add CStr(i)
dCompare = dCompare + Elements(i)
' check if target achieved
If Abs(Goal - dCompare) < (0.001 + Tolerance) Then
'Goal achieved
Dim vResult As Variant
ReDim vResult(1 To SoFar.Count, 1 To 3)
For n = 1 To SoFar.Count
vResult(n, 1) = Elements(SoFar(n))
vResult(n, 2) = Invno(SoFar(n))
vResult(n, 3) = Due(SoFar(n))
Next
Combinations2 = vResult
ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
'Enough room for another element
'Call recursively starting with next higher amount
vResult = Combinations2(Elements, Invno, Due, Goal, Tolerance, SoFar, i + 1)
If IsArray(vResult) Then
Combinations2 = vResult
Exit For
Else
SoFar.Remove SoFar.Count
dCompare = dCompare - Elements(i)
End If
Else
'Amount too high
SoFar.Remove SoFar.Count
Exit For
End If
Next
End Function
Sub BubbleSort(ByRef ar1 As Variant, ByRef ar2 As Variant, ByRef ar3 As Variant)
' sort both arrays
Dim d, s, i As Long, k As Long, dt As Date
For i = 1 To UBound(ar1)
For k = i + 1 To UBound(ar1)
If (ar1(k) < ar1(i)) Or _
(ar1(k) = ar1(i) _
And ar3(k) < ar3(i)) Then
d = ar1(i)
ar1(i) = ar1(k)
ar1(k) = d
s = ar2(i)
ar2(i) = ar2(k)
ar2(k) = s
dt = ar3(i)
ar3(i) = ar3(k)
ar3(k) = dt
End If
Next
Next
End Sub
Get nth match in Index
Please refer this exceljet page for function for getting nth match which is used in index function for finding the match for the nth position given by countif function as last argument of small function. Range in the countif function need to be fixed at the first cell only. So, when we copy the formula below we get relative increment in the 'n' in case of duplicate matches. So, Index function will give the incremental nth position value.
Array CSE(Control+Shift+Enter) Formula for in F3 and copy down
=INDEX(ColEResultRangeFixed,SMALL(IF(ColAValuesRangeFixed=ColEResultCriteria,ROW(ColAValuesRangeFixed)-MIN(ROW(ColAValuesRangeFixed))+1),COUNTIF($ColAValuesRangeFixedFirst,ColEResultCriteria)))
In this case.. CSE Formula in F3 and then copy down
=INDEX($B$2:$B$11,SMALL(IF($A$2:$A$11=E3,ROW($A$2:$A$11)-MIN(ROW($A$2:$A$11))+1),COUNTIF($E$3:E3,E3)))
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
data series
I want to find the average for each segment of ten values down a column. (See data series picture)
Continuously all the way to the bottom of the data set. The data set can vary in length, and the code has to be "generic" of sorts.
Based on other code segments I have tried to do this:
Sub tenthavg()
Dim currentIndex As Long
Dim myArray() As Variant
Dim rng As Range
ReDim myArray(1 To 10)
Range("b1", Range("b1").End(xlDown)).Select
Set myArray = Selection
currentIndex = 1
Do Until currentIndex + 1 > UBound(myArray)
ActiveSheet.Cells(currentIndex, "T") = AverageOfSubArray(myArray, currentIndex, 10)
currentIndex = currentIndex + 1
Loop
End Sub
'=================================================================
Function AverageOfSubArray(myArray As Variant, startIndex As Long, elementCount As Long) As Double
Dim runningTotal As Double
Dim i As Long
For i = startIndex To (startIndex + elementCount - 1)
runningTotal = runningTotal + val(myArray(i))
Next i
AverageOfSubArray = runningTotal / elementCount
End Function
Unfortunately I can't make it work. Am I approaching this the right way?
If so, what am I doing wrong?
IMHO it's not quite the successful approach ... instead of Selecting EndDown and other concepts borrowed from interactive working make use of VBA's own mechanisms.
A "generic" approch takes Range start address, batch size and offsets where to put the result as arguments ...
Sub AvgX(MyR As Range, S As Integer, ORow As Integer, OCol As Integer)
' MyR = start of range
' S = batch size
' OCol, ORow = Offsets to place result in relation to last batch value
Dim Idx As Integer, Jdx As Integer, RSum As Variant
Idx = 1
RSum = 0
Do
For Jdx = 1 To S
RSum = RSum + MyR(Idx, 1)
Idx = Idx + 1
If MyR(Idx, 1) = "" Then Exit Do
Next Jdx
MyR(Idx - 1, 1).Offset(ORow, OCol) = RSum / (Jdx - 1)
RSum = 0
Loop
End Sub
and is called by
Sub Test()
AvgX [C4], 10, 0, 1
End Sub
to give you this result ...
You can get your result in a simpler way:
Sub tenthavg()
Dim LastRow As Long
LastRow = ThisWorkbook.Sheets("Your Sheet Name").Columns(2).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Dim myArray(1 To 10) As Double
If LastRow < 10 Then
MsgBox "There's not enough data!"
Else
On Error Resume Next
For x = 1 To LastRow - 9
For y = 1 To 10
myArray(y) = ThisWorkbook.Sheets("Your Sheet Name").Cells(y + x - 1, 2).Value
Next y
ThisWorkbook.Sheets("Your Sheet Name").Cells(x, 20).FormulaR1C1 = 0
ThisWorkbook.Sheets("Your Sheet Name").Cells(x, 20).FormulaR1C1 = Application.Average(myArray)
Next x
End If
End Sub
Please note: I'm assuming you're data starts at B1 and you want the output on column T.
This is a console application which generates a times table with user input by asking the user to input rows and columns. I get two big errors in this code:
Value of type '1-dimensional array of 1-dimensional array of Integer' cannot be converted to '1-dimensional array of Integer' 'because '1-dimensional array of Integer' is not derived from 'Integer'
and
'jaggedArrayArray' is not declared. It may be inaccessible due to its protection level.
After some research online, I have come across two big concepts - Deep Copy and Shallow Copy - which I am still learning. I think that my main problem has to do with Sub arrayPopulateJ:
Sub arrayPopulateJ(ByVal jaggedArray() As Integer, ByVal columns As Integer, ByVal rows As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim mult(columns) As Integer
'Populates rows in jagged array
For i = 0 To rows
jaggedArray(i) = (i + 1)
Next
'Populates columns in arrays
For i = 0 To rows
For j = 0 To columns
For k = 0 To columns
mult(k) = (j + 1) * (k + 1)
Next
Next
jaggedArray(i) = mult(columns)
Next
End Sub
If you look at the line jaggedArray(i) = mult(columns) I think I am doing what is called a shallow copy and it is making this whole thing not work. What I want to happen is I want to be able to use jaggedArray as a 1D array and put 1D arrays into its elements (in my code that would be mult(columns)). I am still new to programming and VB and I am not sure how to do this. I thought that VB would be a high enough language that the flow of logic would work this way. But as I know now that is not the case. So what can I do to pass an whole array into a array and get this to work?
FULL CODE:
Module Module1
Sub Main()
'Declarations
Dim awns As Char
Dim switchOption As Integer
Dim columns As Integer
Dim rows As Integer
Dim regularArray(,) As Integer = New Integer(,) {}
Dim jaggedArray()() As Integer = New Integer(rows)() {} 'Problem here
Dim topArray(columns) As Integer
Dim sideArray(rows) As Integer
'Starting Prompts
Console.WriteLine("Hello this program will create a times table with")
Console.WriteLine("user inputs in terms of rows and columns.")
Console.WriteLine("Pick between these two options.")
Console.WriteLine("Option 1: Times table with a regular array.")
Console.WriteLine("Option 2: Times table with a jagged array.")
Do
Console.Write("Which option do you want? ")
switchOption = Console.ReadLine
Console.WriteLine("How many columns do you want? ")
columns = Console.ReadLine
columns = columns - 1
Console.WriteLine("How many rows do you want? ")
rows = Console.ReadLine
rows = rows - 1
Console.Write(vbNewLine)
'ReDim's
ReDim regularArray(columns, rows)
ReDim jaggedArray(rows)
ReDim topArray(columns)
ReDim sideArray(rows)
Select Case switchOption
Case 1
'Array populations
arrayPopulate(regularArray, columns, rows)
singlePopulate(topArray, columns)
singlePopulate(sideArray, rows)
Dim i As Integer
Dim j As Integer
Console.Write(" ")
For j = 0 To columns
Dim top As String = topArray(j)
Console.Write(top.PadLeft(3) + ": ")
Next
Console.Write(vbNewLine)
For j = 0 To rows
Dim side As String = sideArray(j)
Console.Write(side.PadLeft(3) + ": ")
For i = 0 To columns
Dim num As String = regularArray(i, j)
Console.Write(num.PadLeft(3) + ": ")
Next
Console.Write(vbNewLine)
Next
Case 2
'Array populations
arrayPopulateJ(jaggedArray, columns, rows) 'Problem here
singlePopulate(topArray, columns)
singlePopulate(sideArray, rows)
Dim i As Integer
Dim j As Integer
Console.Write(" ")
For j = 0 To columns
Dim top As String = topArray(j)
Console.Write(top.PadLeft(3) + ": ")
Next
Console.Write(vbNewLine)
For j = 0 To rows
Dim side As String = sideArray(j)
Console.Write(side.PadLeft(3) + ": ")
Dim num As String = jaggedArrayArray(j) 'Problem here
Console.Write(num.PadLeft(3))
Console.Write(vbNewLine)
Next
End Select
Console.WriteLine("Do you want to run again y/n?")
awns = Console.ReadLine()
Loop Until awns = "n"
End Sub
Sub arrayPopulateJ(ByVal jaggedArray() As Integer, ByVal columns As Integer, ByVal rows As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim mult(columns) As Integer
ReDim mult(columns)
'Populates rows in jagged array
For i = 0 To rows
jaggedArray(i) = (i + 1)
Next
'Populates columns in arrays
For i = 0 To rows
For j = 0 To columns
For k = 0 To columns
mult(k) = (j + 1) * (k + 1)
Next
Next
jaggedArray(i) = mult(columns)
Next
End Sub
Sub arrayPopulate(ByVal regularArray(,) As Integer, ByVal columns As Integer, ByVal rows As Integer)
'Local Declarations
Dim i As Integer
Dim j As Integer
Dim mult As Integer
For i = 0 To rows
For j = 0 To columns
mult = (i + 1) * (j + 1)
regularArray(j, i) = mult
Next
Next
End Sub
Sub singlePopulate(ByVal topArray() As Integer, ByRef count As Integer)
'Local Declarations
Dim i As Integer
Dim pop As Integer
For i = 0 To count
pop = (i + 1)
topArray(i) = pop
Next
End Sub
End Module
There is no "deep" or "shallow" copy issue here. That's a red herring.
Your first problem was that you had jaggedArrayArray in your code, but the variable was declared as jaggedArray.
The next problem that arrayPopulateJ was expecting the first parameter to be of type Integer() when it should have been Integer()().
Fixing both of this it was then just an easy matter of writing arrayPopulateJ to be:
Sub arrayPopulateJ(ByVal jaggedArray()() As Integer, ByVal columns As Integer, ByVal rows As Integer)
For i = 0 To rows
Dim column(columns) As Integer
jaggedArray(i) = column
For j = 0 To columns
jaggedArray(i)(j) = (i + 1) * (j + 1)
Next
Next
End Sub
I also cleaned up arrayPopulate to be:
Sub arrayPopulate(ByVal regularArray(,) As Integer, ByVal columns As Integer, ByVal rows As Integer)
For i = 0 To rows
For j = 0 To columns
regularArray(j, i) = (i + 1) * (j + 1)
Next
Next
End Sub
I ran your code at that point and it worked.