I'm trying to run through a column of values, compare it to a supplied string, if it matches the string, add the value 4 columns over into an array, then sum the array at the end of the function.
The function exits out (not fails) at the ReDim Preserve line.
If I comment that out, it fails at the SumArray(Count) line.
What am I missing?
'Function used to SUM
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim SumArray As Variant
Dim Count As Long
Dim cell As Range
Dim i As Integer
Count = 0
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
BookofDaveSum.Add cell.Value2, 0
ReDim Preserve SumArray(0 To Count)
SumArray(Count) = cell.Offset(0, 4)
Count = Count + 1
End If
End If
Next cell
TotalSum = Application.WorksheetFunction.Sum(SumArray)
End Function
Since you are iterating the range you are not gaining anything by using the array. Simply keep a running total:
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim cell As Range
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
TotalSum = TotalSum + cell.Offset(0, 4).Value2
End If
End If
Next cell
End Function
If your concern is speed then convert both ranges to arrays and iterate the array:
Public Function TotalSum(prefix As String, rng As Range) As Long
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim chRng As Variant
chRng = rng.Value2
Dim addRng As Variant
addRng = rng.Offset(, 4).Value2
Dim temp As Long
temp = 0
Dim i As Long
For i = LBound(chRng, 1) To UBound(chRng, 1)
If Left(chRng(i, 1), 7) = prefix Then
If Not BookofDaveSum.Exists(chRng(i, 1)) Then
temp = temp + addRng(i, 1)
End If
End If
Next cell
TotalSum = temp
End Function
Also this can be done with a formula:
=SUMPRODUCT(((LEFT(A1:A10,7)="abcdefg")*(E1:E10))/(COUNTIFS(A1:A10,A1:A10,A1:A10,"abcdefg" &"*")+(LEFT(A1:A10,7)<>"abcdefg")))
Where abcdefg is your prefix, A1:A10 is the string to test and E1:E10 the values to add
Dim SumArray() As Variant you are trying to redim a variable not an array. () indicates you want an array of variants.
Related
I have code to ask a user for a series of codes that then creates a single-dimensional array like this:
Dim strDaysTimes As String
Dim arrDaysTimes() As String
strDaysTimes = InputBox("What days and times do you want to schedule meetings for? (write as 6c,7b)", "Enter Days and Times")
arrDaysTimes() = Split(strDaysTimes, ",")
The number of inputs is not defined but the format is. It could be "6c,7b" or "5a,6b,7b".
I want to convert this into a multi-dimensional array that would carry the values like this (one dimension has the number portion and the other has the letter portion):
5 a
6 b
7 b
I know that I need to use a nested For...Next statements to process multidimensional arrays, but I would appreciate any suggestions.
Use ReDim:
Public Function DivideArray()
Dim strDaysTimes As String
Dim arrDaysTimes() As String
Dim DaysTimes() As String
Dim Index As Integer
strDaysTimes = InputBox("What days and times do you want to schedule meetings for? (write as 6c,7b)", "Enter Days and Times")
arrDaysTimes() = Split(strDaysTimes, ",")
ReDim DaysTimes(UBound(arrDaysTimes) - LBound(arrDaysTimes) + 1, 0 To 1)
For Index = LBound(arrDaysTimes) To UBound(arrDaysTimes)
DaysTimes(Index, 0) = Left(LTrim(arrDaysTimes(Index)), 1)
DaysTimes(Index, 1) = Right(RTrim(arrDaysTimes(Index)), 1)
Next
For Index = LBound(arrDaysTimes) To UBound(arrDaysTimes)
Debug.Print DaysTimes(Index, 0), DaysTimes(Index, 1)
Next
End Function
Input example:
a7, b8, c9
Output:
a 7
b 8
c 9
Just for the sake of the art an alternative to #Gustav 's approach with the bonus that it returns token lengths greater than 1, too.
Furthermore it profits from the fact that the Val() function is able to return
a) the starting numeric value from an input string and
b) the closing string by a split via the above numeric value as delimiter.
Public Function tokenize(ByVal s As String)
Dim arr() As String
arr() = Split(Trim(s), ",")
Dim tmp() As String
ReDim tmp(0 To UBound(arr) - LBound(arr), 0 To 1)
Dim i As Long
For i = LBound(arr) To UBound(arr)
Dim num: num = Val(arr(i))
tmp(i, 0) = num
tmp(i, 1) = Split(arr(i), num)(1)
Next
tokenize = tmp
End Function
Example call
Sub testTokenize()
'0. Get input string (e.g. "6c,7b")
Dim strDaysTimes As String
strDaysTimes = InputBox( _
"What days and times do you want to schedule meetings for? (write as 6c,7b)", _
"Enter Days and Times", _
"6c,7b")
'1. Call help function
Dim results As Variant
results = tokenize(strDaysTimes) ' << function tokenize()
'2. Show results in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print results(i, 0), results(i, 1)
Next
End Sub
The following code will help you get there.
The GetDaysAndTimes function will return a Jagged array (i.e. an array of arrays). This means that to get the Day and Time of Item 3 you would use ArrayName(2)(0) and ArrayName(2)(1) where arrayname is the name of the array you are using (arrayDaysTimes?)
The function SplitAlphaNumString allows users to enter codes such as AB23.
Option Explicit
' This function takes the string returned by your input box
Public Function GetDaysAndTimes(ByRef ipString As String) As Variant
Dim myItems As Variant
myItems = VBA.Split(ipString, ",")
Dim myDayTimes As Variant
Dim myindex As Long
For myindex = LBound(myItems) To UBound(myItems)
myDayTimes(myindex) = SplitAlphaNumString(myItems(myindex))
Next
GetDaysAndTimes = myDayTimes
End Function
Public Function SplitAlphaNumString(ByVal ipString As String) As Variant
Dim myindex As Long
For myindex = 1 To VBA.Len(ipString)
If VBA.Asc(VBA.Mid(ipString, myindex, 1)) < 58 Then
Dim myAlphas As String
myAlphas = VBA.Mid(ipString, 1, myindex - 1)
Dim myNums As String
myNums = VBA.Mid(ipString, myindex)
SplitAlphaNumString = Array(myAlphas, myNums)
Exit Function
End If
Next
End Function
Sub Test()
Dim myArray As Variant
myArray = SplitAlphaNumString("D5")
Debug.Print myArray(0), myArray(1)
End Sub
I want to check if the current destination string is located within the destination search array once the origins match up. The outcome is supposed to be all flights between any originSearch city and destinationSearch city and the corresponding flight number
I was playing with a boolean that stores all the true matches but I got confused.
Sub Matches()
Dim nFlights As Integer
Dim origin() As String
'Dim isOwned() As Boolean
Dim flightNumber() As String
Dim destination() As String
Dim iOrigin As Integer
Dim iDestination As Integer
Dim iFlight As Integer
Dim nOrigins As Integer
Dim nDestinations As Integer
Dim originSearch() As String
Dim destinationSearch() As String
Dim i As Integer
Dim x As Integer
Dim m As Integer
With wsData.Range("A1")
nFlights = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
ReDim origin(1 To nFlights)
ReDim flightNumber(1 To nFlights)
ReDim destination(1 To nFlights)
'ReDim isOwned(1 To nFlights)
'stores the origin column in an array
For iOrigin = 1 To nFlights
'isOwned(iOrigin) = False
origin(iOrigin) = .Offset(iOrigin, 0).Value
Next
'stores the destination column in an array
For iDestination = 1 To nFlights
'isOwned(iDestination) = False
destination(iDestination) = .Offset(iDestination, 1).Value
Next
'stores the flight column in an array
For iFlight = 1 To nFlights
'isOwned(iFlight) = False
flightNumber(iFlight) = .Offset(iFlight, 2).Value
Next
End With
With wsData.Range("E1")
nOrigins = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
nDestinations = 4 'Range(.Offset(1, 1), .End(xlDown)).Rows.Count
ReDim originSearch(1 To nOrigins)
ReDim destinationSearch(1 To nDestinations)
For i = 1 To nOrigins
originSearch(i) = .Offset(i, 0).Value
For x = 1 To nDestinations
destinationSearch(x) = .Offset(x, 1).Value
For m = 1 To nFlights
If origin(m) = originSearch(i) And destination(m) = destinationSearch(x) Then
wsData.Range("H1").Offset(i, 0).Value = originSearch(i)
wsData.Range("H1").Offset(x, 1).Value = destinationSearch(x)
wsData.Range("H1").Offset(x, 2).Value = flightNumber(m)
End If
Next m
Next x
Next i
End With
End Sub
I think you can solve the problem with this formula:
=FILTER(AllFlights;IFNA(MATCH(AllFlights[Origin];DesiredOrigin;0)*MATCH(AllFlights[Destination];DesiredDestination;0);0);)
Here:
AllFlights is the name of a table with all possible flights;
DeiredOrigin is the name of a table with origins of interest;
DeiredDestination is the name of a table with destinations of interest;
Multiplication of Matches is the matrix equivalent of the OR operator.
p.s. Instead of IFNA we can use ISNUMBER:
=FILTER(AllFlights;ISNUMBER(MATCH(AllFlights[Origin];DesiredOrigin;0)*MATCH(AllFlights[Destination];DesiredDestination;0));)
There should only be a single nested for loop at the end there.
So for each origin_dest-pair search value,
you're searching each origin_dest-pair record value.
This adds all the flight numbers of matching scenarios into an array and then puts the flight numbers into the next available column.
Also Ranges are essentially Variant() arrays, so you can just assign one to the other, instead of iterating through each value.
Option Compare Text
Sub FindFlightNumbers()
Dim orig() As Variant: orig = Range("A2:A" & Range("A2").End(xlDown).Row)
Dim dest() As Variant: dest = Range("B2:B" & Range("B2").End(xlDown).Row)
Dim flight_nums() As Variant: flight_nums = Range("C2:C" & Range("C2").End(xlDown).Row)
'Turn 2-D arrays into 1-D arrays
orig = Application.Transpose(orig)
dest = Application.Transpose(dest)
flight_nums = Application.Transpose(flight_nums)
Dim orig_search As Range: Set orig_search = Range("E2:E" & Range("e2").End(xlDown).Row)
Dim search_cell As Range, i As Integer
For Each search_cell In orig_search
Dim match_numbers() As Variant
For i = 1 To UBound(orig)
If search_cell.Value = orig(i) And search_cell.Offset(0, 1).Value = dest(i) Then
'If its the first match, init the array
If (Not match_numbers) = -1 Then
ReDim Preserve match_numbers(0)
match_numbers(0) = flight_nums(i)
Else
'Otherwise increment the array
ReDim Preserve match_numbers(UBound(match_numbers) + 1)
match_numbers(UBound(match_numbers)) = flight_nums(i)
End If
End If
Next i
'If the array had found matches, store them; comma-delimited
If Not Not match_numbers Then
search_cell.Offset(0, 2).Value = Join(match_numbers, ",")
End If
Erase match_numbers
Next search_cell
End Sub
Here's an approach using Match() directly against the search values on the worksheet:
Sub Matches()
Dim data, m As Long, rngOrigin As Range, rngDest As Range, m As Long, i As Long
'one array of all data: origin|destination|flight#
data = wsdata.Range("A2", wsdata.Cells(Rows.Count, "C").End(xlUp))
'set search ranges
Set rngOrigins = wsdata.Range("E2", wsdata.Cells(Rows.Count, "E").End(xlUp))
Set rngDest = wsdata.Range("F2", wsdata.Cells(Rows.Count, "F").End(xlUp))
'loop all source data
For m = 1 To UBound(data, 1)
'check Match() against search ranges
If Not IsError(Application.Match(data(m, 1), rngOrigins, 0)) Then
If Not IsError(Application.Match(data(m, 2), rngDest, 0)) Then
i = i + 1
wsdata.Range("H1").Offset(i, 0).Resize(1, 3) = _
Array(data(m, 1), data(m, 2), data(m, 3))
End If
End If
Next m
End Sub
I have a function that loads certain data from a dynamic table into an array. The function works fine, when I check the local window I get the correct data. Also when I call the data from a sub, everything seems to work fine till I write the array to a new sheet, then I only get the first record repeatedly.
This is my code:
Function LoadData() As String()
Dim rng2 As Range, intJaNein As Integer, rngZelle As Range, X As Integer, cntAnzahl As Integer
Dim strAusgabe() As String 'R?ckgabe Array
intJaNein = 1
X = 0
Set rng2 = Range("tblMaschinen[DisplayList]")
cntAnzahl = WorksheetFunction.CountIfs(rng, m_intListIndex, rng2, intJaNein)
ReDim strAusgabe(cntAnzahl)
For Each rngZelle In rng2.Cells
If rngZelle.Offset(, -2).value = 0 And _
rngZelle.value = 1 And _
X <= cntAnzahl Then
strAusgabe(X) = rngZelle.Offset(, -1).value
X = X + 1
End If
Next rngZelle
LoadData = strAusgabe
End Function
Sub Test()
Dim sht As Worksheet, rng As Range, arr() As String
If ThisWorkbook.Worksheets("Loeschen") Is Nothing Then
Set sht = ActiveWorkbook.Worksheets.Add
sht.Name = "Loeschen"
End If
Set rng = Range("A1:A19")
arr = cls.LoadData
rng.value = arr
End Sub
This is the locals output when getting to the last row of code (rng.value = arr)
And this is what appears in my worksheet.
I have a column with different values. I have to select only unique values from the column and put in an array.
I am using following code for the same but it puts unique values in another column rather array.
Sub GetUniqueSections()
Dim d As Object, c As Variant, i As Long, lastRow As Long
Dim a(8) As String
Dim j
Set d = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("C2:C" & lastRow)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("R2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
In the code below, UniqueValueArrayFromRange replaces your GetUniqueSections using the same technique with a Scripting.Dictionary. You can substitute "A1:A14" with whatever you need and the output array will be in arr:
Option Explicit
Sub Test()
Dim rng As Range
Dim arr As Variant
Dim i As Integer
' pass range values to function for unique values
Set rng = Sheet1.Range("A1:A14")
arr = UniqueValueArrayFromRange(rng)
' test return values
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
Function UniqueValueArrayFromRange(ByRef rngSource As Range) As Variant
Dim dic As Object
Dim rngCell As Range
' create dictionary and only add new values
Set dic = CreateObject("Scripting.Dictionary")
For Each rngCell In rngSource
If Not dic.Exists(rngCell.Value) Then
dic.Add rngCell.Value, 1
End If
Next rngCell
' return key collection as array
UniqueValueArrayFromRange = dic.Keys
End Function
I'm trying to create a function (that when you pass it an array (Maybe a range is better?) that it outputs all the unique values in the same row on different cells.
I've gotten as far as knowing how to identify the elements (which I don't think I've done right :( ) but I'm not sure how I'd output all the unique values. I only get the first one.
My code is as follows:
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
'If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
AddItem:
'If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
Something like:
Function UniqueItems(ArrayIn) As Variant
Dim vData As Variant
Dim vNewdata() As Variant
Dim colUniques As Collection
Dim lCt As Long
If TypeName(ArrayIn) = "Range" Then
vData = ArrayIn.Value
Else
vData = ArrayIn
End If
Set colUniques = New Collection
'assuming a one-column range
On Error Resume Next 'ignore duplicates
For lCt = 1 To UBound(vData, 1)
colUniques.Add vData(lCt, 1), CStr(vData(lCt, 1))
Next
ReDim vNewdata(1 To 1, 1 To colUniques.Count)
For lCt = 1 To colUniques.Count
vNewdata(1, lCt) = colUniques(lCt)
Next
UniqueItems = vNewdata
End Function
you might use Scripting.dictionary to get unique value fast as for exemple
Sub TestArray()
Dim arrStart() As Variant
Dim oDic As Scripting.Dictionary
arr = Array(1, 1, 1, 2, 3, 4, 4, 5)
Set oDic = uniquevalue(arr)
'Note : put data into array
Dim arrResult() As Variant
arrResult = oDic.Keys
'Note : put data into string
Dim stringResult As String
stringResult = Join(oDic.Keys, ";")
End Sub
Function uniquevalue(ByVal myArray) As Scripting.Dictionary
'Note : Add REF DLL Microsoft Srcipting Runtime before !!
'Note : Option base =0 (standard vbe param)
'Note : Array is mono dimension of any data type
Dim oDic As Scripting.Dictionary
Set oDic = New Scripting.Dictionary
For i = LBound(myArray) To UBound(myArray)
If Not oDic.Exists(myArray(i)) Then oDic.Add myArray(i), oDic.Count
Next i
Set uniquevalue = oDic
End Function