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.
Related
I'm working on a VBA word script that reads in some names and relevant info from an excel sheet, performs some computations to organize them correctly, and then pastes them into the word doc. This went well until I decided to make a function that would move a cell with the value "Anonymous" to the top of a range. For some reason, this isn't happening, and it appears to be because the .Cells method isn't always referring to the cell it was called on.
As the script itself is fairly long, I won't post the entire thing here. However, the relevant parts are a For loop in the main sub which deals with cells with the value "Anonymous"
For curCol = 7 To 15
lastRow = appXL.Cells(appXL.Rows.Count, curCol).End(xlUp).Row
For curRow = 1 To lastRow
Dim curCell As excel.Range
Set curCell = appXL.Cells(curRow, curCol)
Dim anonCount As Integer
anonCount = 0
If curCell.Value = "Anonymous" Or curCell.Value = "Anonymous*" Then
If anonCount < 1 Then
anonCount = anonCount + 1
MoveAnon (curRow), (curCol), (lastRow)
Else
anonCount = anonCount + 1
curCell.Value = curCell.Value + " (" + CStr(anonCount) + ")"
MoveAnon (curRow), (curCol), (lastRow)
End If
End If
Next curRow
Next curCol
You'll notice that within this loop is a call to a subroutine "MoveAnon" which is
Sub MoveAnon(currentRow As Integer, currentCol As Integer, thelastRow As Integer)
Dim text As String
Debug.Print ("Using Row: " + CStr(currentRow) + ", Column: " + CStr(currentCol) + ", Last Row: " + CStr(thelastRow))
text = excel.Application.ActiveSheet.Cells(currentRow, currentCol)
Debug.Print ("Hit On: " & excel.Application.ActiveSheet.Cells(currentRow, currentCol))
If currentRow > 1 Then
excel.Application.ActiveSheet.Range(excel.Application.ActiveSheet.Cells(1, currentCol).Address, excel.Application.ActiveSheet.Cells(currentRow - 1, currentCol).Address).Cut excel.Application.ActiveSheet.Range(excel.Application.ActiveSheet.Cells(2, currentCol).Address)
excel.Application.ActiveSheet.Cells(1, currentCol).Value = text
End If
End Sub
Through testing and with Deubg.Print, I've noticed that the line Debug.Print ("Hit On: " & excel.Application.ActiveSheet.Cells(currentRow, currentCol)) refers to all manner of different cells then the one on which it was called. For example, whenever I use Cells(6, 15), I get a value from a cell that is actually on row 42, column 15. The difference between the cell its called on and the cell it returns is not always the same (I've seen -7, +36, and 0), but it is always in the correct column.
Does anyone have any idea as to what my cause this behavior to arise? Thanks for any help.
It's much faster to read the whole range into an array, then populate another array of the same size with the "Anonymous*" at the top, and replace the range values using the second array.
Eg.
Sub Tester()
Dim curCol As Long, ws As Worksheet
Set ws = ActiveSheet
For curCol = 7 To 15
MoveAnon ws.Range(ws.Cells(1, curCol), _
ws.Cells(ws.Rows.Count, curCol).End(xlUp))
Next curCol
End Sub
'Given a (single-column) range, move all values like "Anonymous*"
' to the top of the range
Sub MoveAnon(rng As Range)
Const TXT As String = "Anonymous*"
Dim v, i As Long, num As Long
Dim arrIn, arrOut, nA As Long, nX As Long
num = Application.CountIf(rng, TXT) 'how many to float up
If num = 0 Then Exit Sub 'nothing to do here?
arrIn = rng.Value 'read to array
ReDim arrOut(1 To UBound(arrIn, 1), 1 To UBound(arrIn, 2)) 'size output array
For i = 1 To UBound(arrIn, 1) 'loop the input array
v = arrIn(i, 1)
If v Like TXT Then
nA = nA + 1
arrOut(nA, 1) = v '"Anonymous*" goes at the top
Else
nX = nX + 1
arrOut(num + nX, 1) = v 'everything else goes below
End If
Next i
rng.Value = arrOut 'replace using the shuffled array
End Sub
I'm trying to group a number from E column starting with 1, the result should be like as below:
Column
E I
1 1-52
. 54-56
. 58-59
.
52
54
55
56
58
59
And I start to write like this:
Sub Group_Numbers()
Dim a As Variant, b As Variant
Dim i As Long, k As Long
Range("I1") = Range("E1")
k = 1
a = Range("E1", Range("E" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 2 To UBound(a)
If a(i, 1) <> Val(a(i - 1, 1)) + 1 Then
k = k + 1
b(k, 1) = a(i, 1)
Else
b(k, 1) = Split(b(k, 1), "-")(0) & -a(i, 1)
End If
Next i
Range("I2").Resize(l).Value = b
End Sub
However, it prompts an error 9 subscript out of range. Hope to get help right here.
Thanks a lot!
I would do the following
Option Explicit
Public Sub Example()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Dim Data() As Variant ' read input data into array
Data = ws.Range("E1", "E" & LastRow).Value2
Dim OutData() As Variant ' define output array
ReDim OutData(1 To UBound(Data, 1), 1 To 1) As Variant
Dim iOut As Long
iOut = 1
Dim StartVal As Long
StartVal = Data(1, 1) ' initialize start value of a group
Dim iRow As Long
For iRow = 2 To UBound(Data, 1) ' loop through values
' check if value is previous value +1
If Data(iRow, 1) <> Data(iRow - 1, 1) + 1 Then
' if not write output from StartVal to previos value
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
iOut = iOut + 1
' and set curent value as new group start
StartVal = Data(iRow, 1)
End If
Next iRow
' close last group
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
' write array back to cells
ws.Range("I1").Resize(RowSize:=iOut).NumberFormat = "#" 'format cells as text so `1-2` does not get converted into date.
ws.Range("I1").Resize(RowSize:=iOut).Value2 = OutData
End Sub
Alternative via Excel's Filter() function (vers. MS 365)
Disposing of the new dynamic array features you can profit from a worksheet-related formula evaluation via a tabular filter upon the data range rows compared with the same range shifted by 1 resulting in an array of endRows numbers. This is the base for a results array which joins start and end values.
The following code allows to define a flexible source range, as the evaluation takes care of the actual start row in the indicated data column.
Example call //edited responding to comment
Sub Grouping()
'0) get data
Dim src As Range
Set src = Sheet1.Range("E1:E59") ' change to your needs
Dim data As Variant
If src.Rows.Count > 1 Then ' is the usual case
data = src.Value2 ' get 2-dim datafield array
Else ' a one liner is the exception
ReDim data(1 To 1, 1 To 1) ' create 2-dim by ReDim
data(1, 1) = Application.Index(src, 1, 1)
End If
'1a)prepare formula evaluation of endRows
Dim EndPattern As String
EndPattern = "=LET(data,$,FILTER(ROW(OFFSET(data,1,0))-" & src.Row & ",ABS(OFFSET(data,1,0)-data)>1))"
EndPattern = Replace(EndPattern, "$", src.Address(False, False))
'1b)evaluate formula
Dim endRows: endRows = src.Parent.Evaluate(EndPattern)
'~~~~~~~~~~~~~~
'2) get results
'~~~~~~~~~~~~~~
Dim results: results = getResults(data, endRows) '<< Help function getResults
'3) write to any target
With Sheet1.Range("I1")
.Resize(UBound(results), 1) = results
End With
End Sub
Help function getResults() //added responding to comment
The usual result of an evaluation is a 1-based 2-dim array with two exceptions code has to provide for:
a) non-findings (which would result only in a returned error value),
b) only a single return value (which is a 1-dim array).
Not enough with these exceptions, the tricky comparison of identical endRows blocks - being shifted by 1 row - makes it necessary to check for the actual last row number if not comprised in endRows. - Imo this might have been the commented issue by #TecLao.
Function getResults(ByRef data, ByRef endRows)
'Purpose: combine value ranges
Dim results As Variant
Dim n As Long: n = UBound(data)
'a) no end row returned by shift-formula evaluation
If IsError(endRows) Then ReDim endRows(1 To 1): endRows(1) = n
'b) one end row found
If Application.WorksheetFunction.CountA(endRows) = 1 Then
ReDim results(1 To IIf(endRows(1) < n, 2, 1), 1 To 1)
'write results
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1), 1)
If UBound(results) = 2 Then
results(2, 1) = _
"'" & data(endRows(1) + 1, 1) & _
"-" & _
data(n, 1)
End If
'c) several end rows found
Else
Dim increment As Long
If endRows(UBound(endRows), 1) < n Then increment = 1
'write results
ReDim results(1 To UBound(endRows) + increment, 1 To 1)
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1, 1), 1)
Dim i As Long
For i = 2 To UBound(endRows)
results(i, 1) = _
"'" & _
data(endRows(i - 1, 1) + 1, 1) & _
"-" & _
data(endRows(i, 1), 1)
Next
If increment Then
results(i, 1) = "'" & data(endRows(i - 1, 1) + 1, 1) & "-" & data(n, 1)
End If
End If
'function return
getResults = results
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
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:
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub