My data is placed in a range. How do i get an average of a column, with multiple conditions herof an OR condition. in this example Temprange.columns(2) should be "High" or "Major"
This should be done without taking an average of two averages as per below example:
Dim a As Long
Dim b As Long
Dim ObjectKeyCounter As Long
Dim TempRange As Range
Dim TempArr As Variant
Dim MyArray As Variant
a = Application.WorksheetFunction.AverageIfs(TempRange.Columns(20), _
TempRange.Columns(1), TempArr(ObjectKeyCounter), TempRange.Columns(2), "High")
b = Application.WorksheetFunction.AverageIfs(TempRange.Columns(20), _
TempRange.Columns(1), TempArr(ObjectKeyCounter), TempRange.Columns(2), "Major")
MyArray(1, 1) = Application.WorksheetFunction.Average(a, b)
For some reason i can't find anything on the internet so i guess my way around it (and thereby my search) is wrong.
Edit: Thanks to Scott Holtzman, my solution is as follows:
Function AverageIfsOr(ByRef TempArr_Dashboard As Variant, _
ByRef ObjectKeyCounter As Long, _
ByRef TempArr_Data As Range, _
ByRef ColumnToAvg As Long) As Double
Dim vAvg() As Variant
Dim vAvgCounter As Integer
Dim DataRowCounter As Integer
vAvgCounter = 0
For DataRowCounter = 1 To TempArr_Data.Rows.Count
If TempArr_Data(DataRowCounter, 4) = TempArr_Dashboard(ObjectKeyCounter) Then
If TempArr_Data(DataRowCounter, 11) = "High" Or TempArr_Data(DataRowCounter, 11) = "Major" Then
vAvgCounter = vAvgCounter + 1
ReDim Preserve vAvg(vAvgCounter)
vAvg(vAvgCounter) = TempArr_Data(DataRowCounter, ColumnToAvg)
End If
End If
Next DataRowCounter
If vAvgCounter = 0 Then
AverageIfsOr = 0
Else: AverageIfsOr = Application.WorksheetFunction.Average(vAvg)
End If
End Function
There may be an easier way but this works.
Option Explicit
Sub AverageIfsOr()
Dim v As Variant
Dim vAvg() As Variant
v = Range("C4:E7")
Dim i As Integer
For i = 1 To UBound(v) - 1
If (v(i, 1) = "A" Or v(i, 1) = "B") And (v(i, 2) = "High" Or v(i, 2) = "Major") Then
ReDim Preserve vAvg(i)
vAvg(i) = v(i, 3)
End If
Next
MsgBox Application.WorksheetFunction.Average(vAvg)
End Sub
You can play with the If conditions ad nauseam.
Test data is here:
Related
I need to write a lot of strings into a lot of cells quickly.
Here is the code I am currently using
Sub CopyArrayToWorksheet(myarray() As String, myworksheet As Worksheet, ArrayStart As Long, ArrayEnd As Long, SheetFirstRow As Long)
If SheetFirstRow = -1 Then SheetFirstRow = GetLastRow(myworksheet) + 1
myworksheet.Cells(1, 1).Select
Dim x As Long, y As Long
Application.ScreenUpdating = False
For x = ArrayStart To ArrayEnd
For y = LBound(myarray, 2) To UBound(myarray, 2)
'myworksheet.Cells(SheetFirstRow, y + 1).NumberFormat = "#"
myworksheet.Cells(SheetFirstRow, y + 1) = myarray(x, y)
Next y
SheetFirstRow = SheetFirstRow + 1
Next x
Application.ScreenUpdating = True
End Sub
This works, this used the be fast yesterday, it would write about 30'000 cells in a few seconds and now it takes minutes ! Nothing has changed but alas I cannot find what is wrong.
The reason why my data is in a 2 dimension string array is that it was easier and faster for me to perform operations on an array first and I really prefer it that way.
I searched before this and got found to try the Cells(1, 1).Select , this does nothing apparent for me. There is also the screenupdating, no effect again. For reference this is an i5-9500 cpu with 16gb ram.
I have two leads I don't know yet how to implement
First is using "MS project tasks" which I do not yet understand how to use.
And my worry is about putting that in a spreadsheet and it not working on my random colleage's computers ?
Slow VBA macro writing in cells
The other is using the transpose but I can't find a good example AND it seems to be only for unidimensionnal arrays
I also found this suggestion but I'm not sure if that's a good fit for my case or if it would be any faster
VBA Excel large data manipulation taking forever
String Array to Worksheet
A Quick Fix
Sub CopyArrayToWorksheet( _
myArray() As String, _
ByVal myWorksheet As Worksheet, _
ByVal ArrayStart As Long, _
ByVal ArrayEnd As Long, _
ByVal SheetFirstRow As Long)
Dim rCount As Long: rCount = ArrayEnd - ArrayStart + 1
Dim cStart As Long: cStart = LBound(myArray, 2)
Dim cEnd As Long: cEnd = UBound(myArray, 2)
Dim cCount As Long: cCount = cEnd - cStart + 1
Dim Data() As String: ReDim Data(1 To rCount, 1 To cCount)
Dim x As Long, y As Long
Dim r As Long, c As Long
For x = ArrayStart To ArrayEnd
r = r + 1
For y = cStart To cEnd
c = c + 1
Data(r, c) = myArray(x, y)
Next y
c = 0
Next x
If SheetFirstRow = -1 Then SheetFirstRow = GetLastRow(myWorksheet) + 1
With myWorksheet.Cells(SheetFirstRow, "A").Resize(rCount, cCount)
.Value = Data
.NumberFormat = "#"
End With
End Sub
The following code may help you to a solution
Sub AssignArrayToExcelRange()
Dim myArray() As String
ReDim myArray(1 To 5, 1 To 5)
myArray(1, 1) = "Hello"
myArray(1, 2) = "Hello"
myArray(1, 3) = "Hello"
myArray(1, 4) = "Hello"
myArray(1, 5) = "Hello"
myArray(3, 1) = "Hello"
myArray(3, 2) = "Hello"
myArray(3, 3) = "Hello"
myArray(3, 4) = "Hello"
myArray(3, 5) = "Hello"
myArray(5, 1) = "Hello"
myArray(5, 2) = "Hello"
myArray(5, 3) = "Hello"
myArray(5, 4) = "Hello"
myArray(5, 5) = "Hello"
Sheets(1).Range("A1:e5").Value = myArray
Sheets(1).Range("f1:j5").Value = WorksheetFunction.Transpose(myArray)
End Sub
I wrote for myself for these occasions (And use it many times):
Public Sub ArrayToRange(theArray As Variant, firstCell As Range)
Dim w As Worksheet
Dim iStartRow As Integer, iStartCol As Integer
iStartRow = firstCell.Row
iStartCol = firstCell.Column
Set w = firstCell.Parent
With w
.Range(.Cells(iStartRow, iStartCol), .Cells(iStartRow + UBound(theArray, 1) - LBound(theArray, 1), iStartCol + UBound(theArray, 2) - LBound(theArray, 2))).Value = theArray
End With
End Sub
To Test it:
Sub testit()
Dim i As Long, k As Long
Dim a(1 To 10, 1 To 3) As String
For i = 1 To 10
For k = 1 To 3
a(i, k) = i & " : " & k
Next k
Next i
ArrayToRange a, ActiveSheet.Range("b3")
End Sub
I need your help to build a macro that can extract the dates (which are in text format) from a string and report them in a different column - let's say to column K, would you be able to assist?
Below the database in text
Contract
OESX BLT 100 Feb22 Mar22 4200 vs S 5 FESX Mar22 #4080
OESX P 100 Mar22 3050 vs 6 FESX Mar22 #4080
OESX CDIA 100 Feb22 4300 Mar22 4400 vs B 3 FESX Mar22 #4090
OESX CNV 100 Dec23 4100 vs 100 FESX Mar22 #4100
OESX PBUT Feb22 3900 - 4000 - 4100
The length of the column of the database is not fixed, it changes every time.
The final goal would be to put the dates at the beginning of the contract and not in the middle.
I thank you in advance :)
CODE:
Sub Macro8()
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim row
Dim column
Dim value
fndList = Array("Dec22 ", "Dec23 ")
rplcList = Array("", "")
Set sht = Sheets("Data")
****For Each cell In Range("A2:A40")
If InStr(cell.Text, fndList) > 0 Then
cell.Offset(0, 1).value = fndList
End If
Next cell****
For x = LBound(fndList) To UBound(fndList)
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next x
End Sub
Simple original answer:
Function RearrangeContract(ref As String)
Dim I As Integer
Dim N As Integer
Dim Res As String
Dim Con As String
Con = ref
For I = 1 To Len(ref) - 3
For N = 1 To 12
If Mid(ref, I, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
Res = Res & Mid(ref, I, 5) & " "
Con = Replace(Con, Mid(ref, I, 6), "")
End If
Next N
Next I
RearrangeContract = Res & Con
End Function
Should spit out strings exactly as you requested.
[enter image description here][1]
Either use the function in your own code, or import the contract lines into excel and use =RearrangeContract() as a UDF
And here we have an absolute mess of code for such a small task, but I'm roughly 90% sure it will work perfectly.
FYI: I went the lazy route for the sorting, and borrowed a sorting sub from here: https://bettersolutions.com/vba/arrays/sorting-counting-sort.htm
Should rearrange, sort and filter duplicates
in the top function, you can change the date output format here:
"Res(i) = Format(Res(i), "mmmyy")"
Option Explicit
Option Base 0
Function RearrangeContractUnique(ref As String)
Dim i As Integer 'Character counter
Dim N As Integer 'Month counter
Dim Res() 'Result
Dim Con As String 'Contract - dates
Dim CNT As Integer 'Date found counter
Dim Temp
CNT = 0 'Counter to 0
Con = ref 'Store reference separately
For i = 1 To Len(ref) - 3 'Cycle through character in ref
For N = 1 To 12 'Test each month againt section of ref
If Mid(ref, i, 3) = Format(DateSerial(2021, N, 15), "mmm") Then
CNT = CNT + 1 'Increment counter
ReDim Preserve Res(1 To CNT) 'Resize array
'Debug.Print Mid(ref, i + 3, 2)
Res(CNT) = DateValue(DateSerial(20 & Mid(ref, i + 3, 2), N, 1))
Con = Replace(Con, Mid(ref, i, 6), "") 'Remove date found from ref
End If
Next N
Next i
'Debug.Print "PreSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
Array_CountingSort Res
'Debug.Print "PostSort"
'For i = 1 To CNT
'Debug.Print Res(i)
'Next i
'Reformat for output
For i = 1 To CNT
Res(i) = Format(Res(i), "mmmyy")
Next i
'Yeah, just shovel more worksheetfunctions into it.
RearrangeContractUnique = Join(Application.WorksheetFunction.Transpose _
(WorksheetFunction.Unique(Application.WorksheetFunction. _
Transpose(Res())))) & " " & Con
End Function
Public Sub Array_CountingSort(ByRef vArrayName As Variant)
Dim vCounting() As Long
Dim lLower As Long
Dim lUpper As Long
Dim larraymin As Long
Dim larraymax As Long
Dim i As Long
Dim j As Long
Dim lnextpos As Long
larraymin = Helper_Minimum(vArrayName)
larraymax = Helper_Maximum(vArrayName)
lLower = LBound(vArrayName)
lUpper = UBound(vArrayName)
ReDim vCounting(larraymin To larraymax)
For i = lLower To lUpper
vCounting(vArrayName(i)) = vCounting(vArrayName(i)) + 1
Next i
lnextpos = lLower
For i = larraymin To larraymax
For j = 1 To vCounting(i)
vArrayName(lnextpos) = i
lnextpos = lnextpos + 1
Next j
Next i
End Sub
Public Function Helper_Maximum(ByVal vArrayName As Variant) As Long
Dim lmaxvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lmaxvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) > lmaxvalue) Then
lmaxvalue = vArrayName(i)
End If
Next i
Helper_Maximum = lmaxvalue
End Function
Public Function Helper_Minimum(ByVal vArrayName As Variant) As Long
Dim lminvalue As Long
Dim lrowlower As Long
Dim lrowupper As Long
Dim i As Long
lrowlower = LBound(vArrayName)
lrowupper = UBound(vArrayName)
lminvalue = vArrayName(lrowlower)
For i = lrowlower To lrowupper
If (vArrayName(i) < lminvalue) Then
lminvalue = vArrayName(i)
End If
Next i
Helper_Minimum = lminvalue
End Function
I am trying to copy data from one workbook to another based on the values contained in cells in the source workbook that matches the same values in the target workbook. For example, I have a table (Table1) that has four columns say, A1:D5. One of these columns (column A) contains account numbers that match similar account numbers located on another workbook (also in column A). I am trying to find a code that looks through the table (Table1) in the source workbook via the account number column, and if the account number matches the account number in the target workbook, copy and paste the cells on that row in specific locations to the target workbook. Is this possible?
I hope that makes sense. I have looked all over on how to structure such a code, and I was not able to find anything to start the process for this logic.
Any help will be very appreciative.
Thank you
Even if your question is about doing this in VBA, I'm just going to mention that what you are trying to do seems like it could also be done with Power Query.
That being said, if you were to use VBA for this, you would have to use the Match function to find where your rows match and then copy the data from the source to the destination table.
I've adapted the code I provided to this question to better serve your specific needs. One of the things I've done is to add an optional argument called DoOverwrite and set it to false. This will make sure that the information from one row won't be overwritten by another row later down the road.
Sub TableJoinTest()
'Those table columns will have to match for the 2 lines to be a match
Dim MandatoryHeaders() As Variant
MandatoryHeaders = Array("Account Number")
Dim SourceTableAnchor As Range
Set SourceTableAnchor = Workbooks("SourceWorkbook.xlsx").Sheets("Sheet1").Range("A1")
Dim TargetTableAnchor As Range
Set TargetTableAnchor = Workbooks("TargetWorkbook.xlsx").Sheets("Sheet1").Range("A1")
TableJoin _
SourceTableAnchor:=SourceTableAnchor, _
TargetTableAnchor:=TargetTableAnchor, _
MandatoryHeaders:=MandatoryHeaders, _
AddIfMissing:=False, _
IsLogging:=False, _
DoOverwrite:=False
End Sub
Sub TableJoin( _
SourceTableAnchor As Range, _
TargetTableAnchor As Range, _
MandatoryHeaders As Variant, _
Optional OtherHeaders As Variant, _
Optional AddIfMissing As Boolean = False, _
Optional IsLogging As Boolean = False, _
Optional DoOverwrite As Boolean = True)
'''''''''''''''''''''''''''''''''''''''
'Definitions
'''''''''''''''''''''''''''''''''''''''
Dim srng As Range, trng As Range
Set srng = SourceTableAnchor.CurrentRegion
Set trng = TargetTableAnchor.CurrentRegion
Dim sHeaders As Range, tHeaders As Range
Set sHeaders = srng.Rows(1)
Set tHeaders = trng.Rows(1)
'Store in Arrays
Dim sArray() As Variant 'prefix s is for Source
sArray = ExcludeRows(srng, 1).Value2
Dim tArray() As Variant 'prefix t is for Target
tArray = ExcludeRows(trng, 1).Value2
Dim sArrayHeader As Variant
sArrayHeader = sHeaders.Value2
Dim tArrayHeader As Variant
tArrayHeader = tHeaders.Value2
'Find Column correspondance
Dim sMandatoryHeadersColumn As Variant
ReDim sMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim tMandatoryHeadersColumn As Variant
ReDim tMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim k As Long
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), sArrayHeader, 0)
tMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), tArrayHeader, 0)
Next k
Dim sOtherHeadersColumn As Variant
ReDim sOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
Dim tOtherHeadersColumn As Variant
ReDim tOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
sOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), sArrayHeader, 0)
tOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), tArrayHeader, 0)
Next k
'Merge mandatory headers into one column (aka the helper column method)
Dim i As Long, j As Long
Dim sHelperColumn() As Variant
ReDim sHelperColumn(LBound(sArray, 1) To UBound(sArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sHelperColumn(i, 1) = sHelperColumn(i, 1) & sArray(i, sMandatoryHeadersColumn(j))
Next j
Next i
Dim tHelperColumn() As Variant
ReDim tHelperColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(tArray, 1) To UBound(tArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
tHelperColumn(i, 1) = tHelperColumn(i, 1) & tArray(i, tMandatoryHeadersColumn(j))
Next j
Next i
'Find all matches
Dim MatchList() As Variant
Dim LoggingColumn() As String
ReDim LoggingColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
ReDim MatchList(LBound(tArray, 1) To UBound(tArray, 1))
For j = LBound(tArray, 1) To UBound(tArray, 1)
If sHelperColumn(i, 1) = tHelperColumn(j, 1) Then
MatchList(j) = 1
End If
Next j
'Get the row number for the match
Dim MatchRow As Long
Select Case Application.Sum(MatchList)
Case Is > 1
'Need to do more matching
Dim MatchingScoresList() As Long
ReDim MatchingScoresList(1 To UBound(tArray, 1))
Dim m As Long
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
For m = LBound(tArray, 1) To UBound(tArray, 1)
If tArray(m, sOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k)) Then
MatchingScoresList(m) = MatchingScoresList(m) + 2 ^ (UBound(OtherHeaders) - k)
End If
Next m
Next k
'Get the max score position
Dim MyMax As Long
MyMax = Application.Max(MatchingScoresList)
If Application.Count(Application.Match(MatchingScoresList(), Array(MyMax), 0)) > 1 Then
MsgBox "Error: can't determine how to match row " & i & " in source table"
Exit Sub
Else
MatchRow = Application.Match(MyMax, MatchingScoresList, 0)
End If
Case Is = 1
MatchRow = Application.Match(1, MatchList, 0)
Case Else
Dim nArray() As Variant, Counter As Long
If AddIfMissing Then
MatchRow = 0
Counter = Counter + 1
ReDim nArray(1 To Counter, 1 To UBound(tArray, 2))
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
nArray(Counter, tMandatoryHeadersColumn(k)) = sArray(i, sMandatoryHeadersColumn(k))
Next k
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
nArray(Counter, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
Next k
Else
MsgBox "Error: Couldn't find a match for data row #" & i
Exit Sub
End If
End Select
'Logging and assigning values
If MatchRow > 0 Then
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
If tArray(MatchRow, tOtherHeadersColumn(k)) <> sArray(i, sOtherHeadersColumn(k)) Then
'Logging
If IsLogging And DoOverwrite Then LoggingColumn(MatchRow, 1) = LoggingColumn(MatchRow, 1) & _
IIf(LoggingColumn(MatchRow, 1) <> "", ", ", "") & _
tHeaders.Cells(1, tOtherHeadersColumn(k)) & " : " & _
tArray(MatchRow, tOtherHeadersColumn(k)) & _
" -> " & sArray(i, sOtherHeadersColumn(k))
'Assign new value
If DoOverwrite Or tArray(MatchRow, tOtherHeadersColumn(k)) = VbNullString Then
tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
End If
End If
Next k
End If
Next i
'Write arrays to sheet
ExcludeRows(trng, 1).Value2 = tArray
With trng.Parent
If IsArrayInitialised(nArray) And AddIfMissing Then
.Cells(trng.Cells(1, 1).Row + trng.Rows.Count, trng.Cells(1, 1).Column).Resize(UBound(nArray, 1), UBound(nArray, 2)).Value2 = nArray
End If
If IsLogging Then
.Cells(trng.Cells(1, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count) = "Changes"
.Cells(trng.Cells(2, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count).Resize(UBound(LoggingColumn, 1), 1).Value2 = LoggingColumn
End If
End With
End Sub
And also add these functions inside your VBA project to as they are used in the procedure above.
Function IsArrayInitialised(ByRef A() As Variant) As Boolean
On Error Resume Next
IsArrayInitialised = IsNumeric(UBound(A))
On Error GoTo 0
End Function
Function ExcludeRows(MyRng As Range, StartRow As Long, Optional EndRow As Long = -1) As Range
'PURPOSE: Exclude one or more consecutives rows from an existing range
Dim Afterpart As Range, BeforePart As Range
If StartRow < 1 Or EndRow > MyRng.Rows.Count Then Set ExcludeRows = Nothing
If StartRow = 1 And EndRow = MyRng.Rows.Count Then Set ExcludeRows = Nothing
If EndRow = -1 Then EndRow = StartRow
If EndRow < MyRng.Rows.Count Then
With MyRng.Parent
Set Afterpart = .Range(MyRng.Cells(EndRow + 1, 1), MyRng.Cells(MyRng.Rows.Count, MyRng.Columns.Count))
End With
End If
If StartRow > 1 Then
With MyRng.Parent
Set BeforePart = .Range(MyRng.Cells(1, MyRng.Cells(1, 1).Column), MyRng.Cells(StartRow - 1, MyRng.Columns.Count))
End With
End If
Set ExcludeRows = Union2(True, BeforePart, Afterpart)
End Function
Public Function Union2(IgnoreEmptyRange As Boolean, ParamArray RangeArray() As Variant) As Range
'PURPOSE: Samae as Application.Union but allows some range object to be Empty
Dim V As Variant
Dim Rng As Range
For Each V In RangeArray
Do
If VarType(V) = vbEmpty Then Exit Do
Set Rng = V
If Not Union2 Is Nothing Then
Set Union2 = Union(Union2, Rng)
ElseIf Not Rng Is Nothing Then
Set Union2 = Rng
End If
Loop While False
Next
End Function
I have a large spreadsheet with tens of thousands of rows. I want to look up values based on multiple criteria and get the associated values. Currently, I use the SUMPRODUCT function, but with that many rows, it takes many minutes to calculate.
Function:
=SUMPRODUCT((array 1 criteria) * (array2 criteria) * array values)
Example:
=SUMPRODUCT((B15:B23=”John”)*(C15:C23=”North”)*(E15:E23=1)*D15:D23)
Example from here.
Question:
Is there a more efficient way to do this type of lookup with multiple criteria - maybe with VBA? I have tried using index match, but it only gives me the value of the first match and I am not sure it is better performance-wise.
If you dont want to use Pivot try this.. As all the arguments are range, select desire range for entering the input.
Function VBSumProd(nameRng As Range, nameCrt As Range, regionRng As Range, regionCrt As Range, salesRng As Range, qtrRng As Range, qrtCrt As Range) As Double
Dim i As Long, tempSum As Double
tempSum = 0
For i = 1 To nameRng.Rows.Count
If WorksheetFunction.And(UCase(nameRng(i)) = UCase(nameCrt), UCase(regionRng(i)) = UCase(regionCrt), qtrRng(i) = qrtCrt) Then
tempSum = tempSum + salesRng(i)
End If
Next
VBSumProd = tempSum
End Function
You tried code below which is slow compared to subtotal
Function VBSumProd(nameRng As Range, nameCrt As String, regionRng As Range, regionCrt As String, salesRng As Range, qtrRng As Range, qrtCrt)
Dim nameRngArr, regionRngArr, salesRngArr, qtrRngArr
Dim i As Long, tempSum As Double
tempSum = 0
ReDim nameRngArr(nameRng.Rows.Count)
ReDim regionRngArr(nameRng.Rows.Count)
ReDim salesRngArr(nameRng.Rows.Count)
ReDim qtrRngArr(nameRng.Rows.Count)
For i = 1 To nameRng.Rows.Count
nameRngArr(i) = nameRng(i)
regionRngArr(i) = regionRng(i)
salesRngArr(i) = salesRng(i)
qtrRngArr(i) = qtrRng(i)
Next
For i = 1 To nameRng.Rows.Count
If WorksheetFunction.And(UCase(nameRngArr(i)) = UCase(nameCrt), UCase(regionRngArr(i)) = UCase(regionCrt), qtrRngArr(i) = qrtCrt) Then
tempSum = tempSum + salesRngArr(i)
End If
Next
VBSumProd = tempSum
End Function
Please try this code. It is very fast, using array and working in memory. Please confirm that it works fast enough for your real case. It works in range "A2:D" & last row, and returns the result in column "E:E".
Sub testSumprodBis()
Dim sh As Worksheet, arrI As Variant, arrF As Variant, lastR As Long
Dim i As Long, j As Long, pCount As Long, d As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & Cells.Rows.count).End(xlUp).row
arrI = sh.Range("A2:D" & lastR).Value
ReDim arrF(1 To UBound(arrI, 1), 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To lastR - 1
If Not d.Exists(UCase(arrI(i, 1) & arrI(i, 2) & arrI(i, 4))) Then
For j = 1 To lastR - 1
If UCase(arrI(i, 1)) = UCase(arrI(j, 1)) And arrI(i, 4) = arrI(j, 4) Then
pCount = pCount + arrI(j, 3)
End If
Next j
d(UCase(arrI(i, 1) & arrI(i, 2) & arrI(i, 4))) = pCount
arrF(i, 1) = pCount: pCount = 0
Else
arrF(i, 1) = d(UCase(arrI(i, 1) & arrI(i, 2) & arrI(i, 4)))
End If
Next
sh.Range("E2").Resize(UBound(arrF, 1), 1).Value = arrF
End Sub
Now, the code uses a dictionary where the already calculated cases are kept and only used for similar ones, instead of recalculating...
Edited: It works almost instant for my case, but this is happening because a only repeated the values taken form your above example. Please let me know how much it takes for your real file.
The current performance of this function is to slow, currently I am working with a list of 500+ item codes on sheet1. The function searches in a range of 200 000 + items on sheet2 to find all matches including partial matches. This means that we include a wildcards before and after the lookup criteria to find all matches.
Currently it takes over 15 mins to complete. Is there a better method to do this? To get this under 5 mins?
Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
Optional ByVal stringsRange As Range, Optional Delimiter As String) As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim i As Long, j As Long, criteriaMet As Boolean
Set compareRange = Application.Intersect(compareRange, _
compareRange.Parent.UsedRange)
If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - _
compareRange.Row, stringsRange.Column - compareRange.Column)
For i = 1 To compareRange.Rows.Count
For j = 1 To compareRange.Columns.Count
If (Application.CountIf(compareRange.Cells(i, j), _
xCriteria)= 1) Then
ConcatIf = ConcatIf & Delimiter & _
CStr(stringsRange.Cells(i, j))
End If
Next j
Next i
ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Function
Example:
+500 ITEM CODES
Sheet1:
BCD
CDF
XLMH
XPT
ZPY
200 000 + FULL ITEM CODES
Sheet2:
FDBCDGH
HSGDBCDSU
GFD-CDFGDTR
SBGCDFHUD
GKJYCDFFDS
DDFGFDXLMHGFD
SDGXLMHSDFS
SDGVSDXLMHFAMN
DDDSXPTDFGFD
JUYXPTFADS
DDDFFZPYDGDFDF
Outcome should be:
Sheet1:
COLUMN A - COLUMN B
BCD - FDBCDGH,HSGDBCDSU
CDF - GFD-CDFGDTR,SBGCDFHUD,GKJYCDFFDS
XLMH - DDFGFDXLMHGFD,SDGXLMHSDFS,SDGVSDXLMHFAMN
XPT - DDDSXPTDFGFD,JUYXPTFADS
ZPY - DDDFFZPYDGDFDF
To use the following code you will need to add a reference to Microsoft Scripting Runtime. This uses two arrays and compiles the data in a dictionary. This can then be written back to your sheet. The code currently writes the results back to the immediate window which can be displayed using Ctrl+G or View->Immediate Window
Public Sub demo()
Dim compArr As Variant, strArr As Variant
Dim strDict As Dictionary
Dim i As Long
Dim Delimiter As String: Delimiter = "; "
Dim key
' Set data to arrays. This assumes your data is in column A
With Sheets("Sheet1")
' Application.Transpose is a trick to convert the range to a 1D array (otherwise a 2D array will be created)
compArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
End With
With Sheets("Sheet2")
strArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
End With
' Initiate dictionary
Set strDict = New Dictionary
' Loop through all the values you wish to find
For i = LBound(compArr) To UBound(compArr)
' Tests if value exists
If Not strDict.Exists(compArr(i)) Then
' Adds value to dictionary and uses filter on string array to get similar matches.
' Join is used to convert the resulting array into a string
strDict.Add key:=compArr(i), Item:=Join(Filter(strArr, compArr(i), True), Delimiter)
End If
Next i
' Read back results
For Each key In strDict.Keys
Debug.Print key, strDict(key)
Next key
End Sub
To maintain all of your current functionality and useability regarding the size of your dataset, this should work for you and be faster than the original code. When I timed it, I used 400,000 full item codes and applied the concatif formula on sheet 1 for 1000 partial matches and it completed all cell calculations in under 9 minutes.
Public Function CONCATIF(ByVal arg_rCompare As Range, _
ByVal arg_vCriteria As Variant, _
Optional ByVal arg_rStrings As Range, _
Optional ByVal arg_sDelimiter As String = vbNullString _
) As Variant
Dim aData As Variant
Dim aStrings As Variant
Dim aCriteria As Variant
Dim vString As Variant
Dim vCriteria As Variant
Dim aResults() As String
Dim ixResult As Long
Dim i As Long, j As Long
If arg_rStrings Is Nothing Then Set arg_rStrings = arg_rCompare
If arg_rStrings.Rows.Count <> arg_rCompare.Rows.Count _
Or arg_rStrings.Columns.Count <> arg_rCompare.Columns.Count Then
CONCATIF = CVErr(xlErrRef)
Exit Function
End If
If arg_rCompare.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = arg_rCompare.Value
Else
aData = arg_rCompare.Value
End If
If arg_rStrings.Cells.Count = 1 Then
ReDim aStrings(1 To 1, 1 To 1)
aStrings(1, 1) = arg_rStrings.Value
Else
aStrings = arg_rStrings.Value
End If
If IsArray(arg_vCriteria) Then
aCriteria = arg_vCriteria
ElseIf TypeName(arg_vCriteria) = "Range" Then
If arg_vCriteria.Cells.Count = 1 Then
ReDim aCriteria(1 To 1)
aCriteria(1) = arg_vCriteria.Value
Else
aCriteria = arg_vCriteria.Value
End If
Else
ReDim aCriteria(1 To 1)
aCriteria(1) = arg_vCriteria
End If
ReDim aResults(1 To arg_rCompare.Cells.Count)
ixResult = 0
For i = LBound(aData, 1) To UBound(aData, 1)
For j = LBound(aData, 2) To UBound(aData, 2)
For Each vCriteria In aCriteria
If aData(i, j) Like vCriteria Then
ixResult = ixResult + 1
aResults(ixResult) = aStrings(i, j)
End If
Next vCriteria
Next j
Next i
If ixResult > 0 Then
ReDim Preserve aResults(1 To ixResult)
CONCATIF = Join(aResults, arg_sDelimiter)
Else
CONCATIF = vbNullString
End If
Erase aData: aData = vbNullString
Erase aCriteria: aCriteria = vbNullString
Erase aResults
End Function