VBA - Countifs time and date by building using variants - vba

I received help in solving a previous question. I would like to solve this problem similarly.
So the situation is similar to a Countifs function, in that I would like it to count if a range equals a certain building, as well as if the date and time that is offset equals a certain date. For example, if the cell in "C1" = "Irving Building" And if the value in "K1" = "Monday" Then I would like it to display in "S1". More specifically if "C1" = "Irving Building" then I want it to count into whatever day and time that corresponds with it, in Column K.
Private Sub TimeAndDate()
Dim n As Double
Dim rep As Worksheet
Dim ws As Worksheet
Dim LastRow As Double
Set rep = Worksheets("Report")
rep.Columns("K:L").ClearContents
For n = 1 To ThisWorkbook.Sheets.Count
Set ws = Worksheets(n)
If IsNumeric(ws.Name) Then
LastRow = rep.Range("K1", rep.Range("K1").End(xlDown)).Rows.Count
LastRow = LastRow + 1
If rep.Range("K1") = "" Then
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K1")
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L1")
Else:
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K" & LastRow)
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L" & LastRow)
End If
End If
Next n
Dim rDts As Range
Dim vDts As Variant
Dim vCnts As Variant
Dim vAP As Variant 'for the AM PM count
Dim vDbld As Variant 'for the date by building
Dim vTbld As Variant 'for thee time by building
Dim i As Long, J As Long
'read dates into array -- faster processing
With rep
vDts = .Range(.Cells(1, 11), .Cells(.Rows.Count, 11).End(xlUp))
End With
'Results array
ReDim vCnts(1 To 7, 1 To 2)
vCnts(1, 1) = "Sunday"
vCnts(2, 1) = "Monday"
vCnts(3, 1) = "Tuesday"
vCnts(4, 1) = "Wednesday"
vCnts(5, 1) = "Thursday"
vCnts(6, 1) = "Friday"
vCnts(7, 1) = "Saturday"
ReDim vAP(1 To 2, 1 To 2)
vAP(1, 1) = "AM"
vAP(2, 1) = "PM"
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
'Do the counts
For i = 1 To UBound(vDts, 1)
J = Weekday(vDts(i, 1))
vCnts(J, 2) = vCnts(J, 2) + 1
If Hour(vDts(i, 1)) < 12 Then
vAP(1, 2) = vAP(1, 2) + 1
Else
vAP(2, 2) = vAP(2, 2) + 1
End If
Next i
'output the results
rep.Range("E1:E14").Copy rep.Range("Q1")
rep.Range("N2:N8").Copy
rep.Range("R1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N11:N12").Copy
rep.Range("Y1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N1") = "DATE"
rep.Range("O1") = "COUNT"
rep.Range("N10") = "TIME"
rep.Range("O10") = "COUNT"
rep.Range("N2:O8").Value = vCnts
rep.Range("N11:O12").Value = vAP
The part that I am needing help on is this part here. These are the variants that I'd like to use, but like I said, earlier, I am unsue as to how to do this without running a ton of countifs statements.
Dim vDbld As Variant 'for the date by building
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
I apologize if this is confusing, I am not completely sure how to word it, thanks in advance.
This is an example of what I'd like it to look like:

What you simply can is to check with Application.Match if the string is in the array and it will give back the index, because this function can only handle one dimensional arrays, there is another function that will give back one dimension of the array. After that you can check the offset and do something with it like this:
Dim mindex as Variant
mindex = Application.Match(rDts(i, 3), Only1D(vDbld, 1), 0)
If Not IsError(mindex) Then
'do stuff i.e
vDbld(mindex, 2) = vDbld(mindex, 2) + 1
End If
Function Only1D(arr As Variant, d As Long)
Dim size As Long: size = UBound(arr, d)
Dim arr2 As Variant
ReDim arr2(1 To size)
For i = 1 To size
arr2(i) = arr(i, d)
Next
Only1D = arr2
End Function

Related

Can I make it faster? I iterates through 20k rows +/- for 4-5 minutes

I am trying to make a macro that assigns the name of maneuver (Ramping Up, Flat Cruise, Ramping Down) for specific behaviour of set of data. I decided to divide the large data set into subsets that consist 5 cells and the code is checking its behaviour (either is the value getting smaller or bigger).
.csv file consists more or less 20k rows and the code iterates through it for 5 minutes. Can I make it somewhat faster?
The outer for loop is dividing the set of data into subsets that consists 5 cells. Slow iterators manipulate those values.
Then it just assigns values depending the values in cells are decreasing or increasing
Sub maneuverSet(lu As Worksheet, nr As Long)
lu.Activate
Dim fast_ite As Long, slow_ite As Integer, numRows As Long
Dim slow_1 As Long, slow_2 As Long, slow_3 As Long, slow_4 As Long, slow_5
numRows = nr 'definition in main: numRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
Application.ScreenUpdating = False
For fast_ite = 4 To numRows Step 5
Dim ite_array As Variant
slow_1 = fast_ite - 2
slow_2 = fast_ite - 1
slow_3 = fast_ite
slow_4 = fast_ite + 1
slow_5 = fast_ite + 2
ite_array = Array(slow_1, slow_2, slow_3, slow_4, slow_5)
' Now it just checks if the cell consist the values that ramping up with each row or not.
If Cells(slow_1, "A") < Cells(slow_2, "A") And Cells(slow_1, "A") < Cells(slow_2, "A") And Cells(slow_2, "A") < Cells(slow_3, "A") _
And Cells(slow_3, "A") < Cells(slow_4, "A") And Cells(slow_4, "A") < Cells(slow_5, "A") Then
For Each iterator In ite_array
Cells(iterator, "AB") = "RampUp"
Next
ElseIf Cells(slow_1, "A") > Cells(slow_2, "A") And Cells(slow_1, "A") > Cells(slow_2, "A") And Cells(slow_2, "A") > Cells(slow_3, "A") _
And Cells(slow_3, "A") > Cells(slow_4, "A") And Cells(slow_4, "A") > Cells(slow_5, "A") Then
For Each iterator In ite_array
Cells(iterator, "AB") = "RampDown"
Next
Else
For Each iterator In ite_array
Cells(iterator, "AB") = "Cruise"
Next
End If
Next
Application.ScreenUpdating = True
End Sub
Read/write to/from cell is usually a very slow action so you will want to avoid that as much as possible.
Instead, store the values into an array then process the logic through the array.
Without changing too much of your logic, this is probably what an array approach looks like:
Sub maneuverSet(lu As Worksheet, nr As Long)
lu.Activate
Dim fast_ite As Long, numRows As Long
numRows = nr 'definition in main: numRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
Application.ScreenUpdating = False
For fast_ite = 4 To numRows Step 5
'Assign the 5 values into an array for processing
Dim dataArr As Variant
dataArr = lu.Cells(fast_ite, "A").Offset(-2).Resize(5).Value
Dim outcome As String 'used to store the outcome of this loop
If dataArr(1, 1) < dataArr(2, 1) And _
dataArr(2, 1) < dataArr(3, 1) And _
dataArr(3, 1) < dataArr(4, 1) And _
dataArr(4, 1) < dataArr(5, 1) Then
outcome = "RampUp"
ElseIf dataArr(1, 1) > dataArr(2, 1) And _
dataArr(2, 1) > dataArr(3, 1) And _
dataArr(3, 1) > dataArr(4, 1) And _
dataArr(4, 1) > dataArr(5, 1) Then
outcome = "RampDown"
Else
outcome = "Cruise"
End If
'Write the outcome into the 5 cells at once.
lu.Cells(fast_ite, "AB").Offset(-2).Resize(5).Value = outcome
Next
Application.ScreenUpdating = True
End Sub
Below should be even faster as it only read and write cells twice:
Sub maneuverSet(lu As Worksheet, nr As Long)
lu.Activate
Application.ScreenUpdating = False
'Read the entire data into an array
Dim dataArr As Variant
dataArr = lu.Range("A2:A" & nr).Value
'Create another array of the same size to store the outcome (to be written into column AB)
Dim outputArr() As String
ReDim outputArr(1 To UBound(dataArr, 1), 1 To 1) As String
'Loop through the array as per your logic
Dim i As Long
For i = 1 To UBound(dataArr, 1) Step 5
Dim outcome As String
If dataArr(i, 1) < dataArr(i + 1, 1) And _
dataArr(i + 1, 1) < dataArr(i + 2, 1) And _
dataArr(i + 2, 1) < dataArr(i + 3, 1) And _
dataArr(i + 3, 1) < dataArr(i + 4, 1) Then
outcome = "RampUp"
ElseIf dataArr(i, 1) > dataArr(i + 1, 1) And _
dataArr(i + 1, 1) > dataArr(i + 2, 1) And _
dataArr(i + 2, 1) > dataArr(i + 3, 1) And _
dataArr(i + 3, 1) > dataArr(i + 4, 1) Then
outcome = "RampDown"
Else
outcome = "Cruise"
End If
Dim n As Long
For n = i To i + 4
outputArr(n, 1) = outcome
Next n
Next i
'Write the entire outcome array into the worksheet
lu.Range("AB2:AB" & nr).Value = outputArr
Application.ScreenUpdating = True
End Sub

VBA refining range

I am attempting to draw data from a separate sheet and put it into a corresponding cell if the conditions are met. My code works, but it is not efficient. I do not know how to change the For Next loop so that it attempts to draw data only until the final entry. Right now I have it set to go a hundred or so cells further than I need so that I wouldn't have to update the code as often when I input new data to the data sheet (or at least that was the thought). Here is my code:
Sub LRearTest()
Dim R As Integer
Dim j As Integer
For j = 89 To 250
For R = 1 To 300
If Worksheets("Input").Cells(j, 22).Value >= Worksheets("1036L").Cells(R, 5).Value And Worksheets("Input").Cells(j, 22).Value <= Worksheets("1036L").Cells(R, 6).Value Then
Worksheets("Input").Cells(j, 20).Value = Worksheets("1036L").Cells(R, 3).Value
End If
Next R
Next j
End Sub
The problem is when I run this code it takes almost two minutes before it is over. I am not sure if it is because I have used j and r as integers or what. Also I have a dozen of these on one module so I am not sure if that contributes. The code works like I said, it is just far too slow. Help is greatly appreciated.
The point that I am checking is in Column V of Sheet "Input". Each of my columns that I want to populate, F - U, use the same data in column V. The sheets that I am comparing the data in column V against are labeled as 1030L, 1030R, 1031L, 1031R, 1032L, 1032R, 1033L, 1033R, 1034L, 1034R, 1034LA, 1034RA, 1035L, 1035R, 1036L, and 1036R. The data being compared is in the same columns in every sheet. Thank you
Something like this should work for you:
Sub LRearTest()
Dim wb As Workbook
Dim wsInput As Worksheet
Dim wsData As Worksheet
Dim aDataParams() As String
Dim aInput As Variant
Dim aData As Variant
Dim InputIndex As Long
Dim DataIndex As Long
Dim ParamIndex As Long
Dim MinCol As Long
Set wb = ActiveWorkbook
Set wsInput = wb.Sheets("Input")
'Adjust the column associations for each sheet as necessary
ReDim aDataParams(1 To 16, 1 To 3)
aDataParams(1, 1) = "1030L": aDataParams(1, 2) = "F"
aDataParams(2, 1) = "1030R": aDataParams(2, 2) = "G"
aDataParams(3, 1) = "1031L": aDataParams(3, 2) = "H"
aDataParams(4, 1) = "1031R": aDataParams(4, 2) = "I"
aDataParams(5, 1) = "1032L": aDataParams(5, 2) = "J"
aDataParams(6, 1) = "1032R": aDataParams(6, 2) = "K"
aDataParams(7, 1) = "1033L": aDataParams(7, 2) = "L"
aDataParams(8, 1) = "1033R": aDataParams(8, 2) = "M"
aDataParams(9, 1) = "1034L": aDataParams(9, 2) = "N"
aDataParams(10, 1) = "1034R": aDataParams(10, 2) = "O"
aDataParams(11, 1) = "1034LA": aDataParams(11, 2) = "P"
aDataParams(12, 1) = "1034RA": aDataParams(12, 2) = "Q"
aDataParams(13, 1) = "1035L": aDataParams(13, 2) = "R"
aDataParams(14, 1) = "1035R": aDataParams(14, 2) = "S"
aDataParams(15, 1) = "1036L": aDataParams(15, 2) = "T"
aDataParams(16, 1) = "1036R": aDataParams(16, 2) = "U"
'Find minimum column
MinCol = wsInput.Columns.Count
For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
If wsInput.Columns(aDataParams(ParamIndex, 2)).Column < MinCol Then MinCol = wsInput.Columns(aDataParams(ParamIndex, 2)).Column
Next ParamIndex
'Based on minimum column, determine column indexes for each sheet/column pair
For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
aDataParams(ParamIndex, 3) = wsInput.Columns(aDataParams(ParamIndex, 2)).Column - MinCol + 1
Next ParamIndex
With wsInput.Range("F89", wsInput.Cells(wsInput.Rows.Count, "V").End(xlUp))
If .Row < 89 Then
MsgBox "No data in sheet [" & wsInput.Name & "]"
Exit Sub
End If
aInput = .Value
End With
For ParamIndex = LBound(aDataParams, 1) To UBound(aDataParams, 1)
'Define data sheet based on current column
Set wsData = wb.Sheets(aDataParams(ParamIndex, 1))
aData = wsData.Range("C1", wsData.Cells(wsData.Rows.Count, "F").End(xlUp)).Value
For InputIndex = LBound(aInput, 1) To UBound(aInput, 1)
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
If aInput(InputIndex, UBound(aInput, 2)) >= aData(DataIndex, 3) _
And aInput(InputIndex, UBound(aInput, 2)) <= aData(DataIndex, 4) Then
aInput(InputIndex, aDataParams(ParamIndex, 3)) = aData(DataIndex, 1)
Exit For
End If
Next DataIndex
Next InputIndex
Set wsData = Nothing
Erase aData
Next ParamIndex
wsInput.Range("F89").Resize(UBound(aInput, 1), UBound(aInput, 2)) = aInput
Set wb = Nothing
Set wsInput = Nothing
Set wsData = Nothing
Erase aInput
Erase aData
Erase aDataParams
End Sub

VBA - CountIf cell range displayed value is equal to desired value

I am having an issue running my code through, because the Range.Value is different than the Range.NumberFormat. For example, my value is a date and time and I would like to test for the day of the week. I was able to get the number format to be Sun-Sat, however, I am unsure how to test for it with CountIf.
Dim rep as Worksheet
Dim day As Range
Dim time As Range
Dim wf As WorksheetFunction
Set rep = Worksheets("Report")
Set day = rep.Range("H1", rep.Range("H1").End(xlDown))
Set time = rep.Range("I1", rep.Range("I1").End(xlDown))
Set wf = WorksheetFunction
With rep
.Columns("H").NumberFormat = "dddd"
.Columns("I").NumberFormat = "AM/PM"
.Range("K1") = "Monday"
.Range("K2") = "Tuesday"
.Range("K3") = "Wednesday"
.Range("K4") = "Thursday"
.Range("K5") = "Friday"
.Range("K6") = "Saturday"
.Range("K7") = "Sunday"
.Range("M1") = "AM"
.Range("M2") = "PM"
.Range("L1") = wf.CountIf(day, "Monday")
.Range("L2") = wf.CountIf(day, "Tuesday")
.Range("L3") = wf.CountIf(day, "Wednesday")
.Range("L4") = wf.CountIf(day, "Thursday")
.Range("L5") = wf.CountIf(day, "Friday")
.Range("L6") = wf.CountIf(day, "Saturday")
.Range("L7") = wf.CountIf(day, "Sunday")
.Range("N1") = wf.CountIf(time, "AM")
.Range("N2") = wf.CountIf(time, "PM")
End With
This is what I have so far, but it only outputs 0 for the solution to the countif. Thanks in advance.
Here's another way to do the counts.
Note I did most of the "work" in VBA arrays as this is much faster than repeatedly accessing the worksheet:
EDIT: To include counting the number of entries in column H with AM or PM times
Option Explicit
Sub foo()
Dim rep As Worksheet
Dim rDts As Range
Dim vDts As Variant
Dim vCnts As Variant 'for the weekday count
Dim vAP As Variant 'for the AM PM count
Dim I As Long, J As Long
Set rep = Worksheets("sheet1")
'read dates into array -- faster processing
With rep
vDts = .Range(.Cells(1, 8), .Cells(.Rows.Count, 8).End(xlUp))
End With
'Results array
ReDim vCnts(1 To 7, 1 To 2)
vCnts(1, 1) = "Sunday"
vCnts(2, 1) = "Monday"
vCnts(3, 1) = "Tuesday"
vCnts(4, 1) = "Wednesday"
vCnts(5, 1) = "Thursday"
vCnts(6, 1) = "Friday"
vCnts(7, 1) = "Saturday"
ReDim vAP(1 To 2, 1 To 2)
vAP(1, 1) = "AM"
vAP(2, 1) = "PM"
'Do the counts
For I = 1 To UBound(vDts, 1)
J = Weekday(vDts(I, 1))
vCnts(J, 2) = vCnts(J, 2) + 1
'Check for AM or PM
If Hour(vDts(I, 1)) < 12 Then
vAP(1, 2) = vAP(1, 2) + 1
Else
vAP(2, 2) = vAP(2, 2) + 1
End If
Next I
'output the results
rep.Range("K1:L7").Value = vCnts
rep.Range("M1:N2").Value = vAP
End Sub

Match Index Issue in VBA

I have the following code. The Loop seems to function well but the ColNum and RowNum lines are only creating 0's the data up to this point is filled out so a blank isn't causing the issue
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") _
And FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
I have used Application.Worksheetfunction on the Index and then it really crashes.
Edit: All Code
Sub TransferData()
'Declarations
Dim ReturnWB As String 'File name from Investment metrics
Dim ReturnWBtab1 As String
Dim ReturnWBtab2 As String
Dim ReturnWBtab3 As String
Dim ColACount As Integer 'Total data in column A of Return Puller
Dim FullDataP As Variant ' Pulling data
Dim FullData As Variant ' Building Matrix
Dim Names As Variant
Dim Unique As Integer 'Total Number of unique names
Dim Months As Integer 'Months Specified
Dim StartYear As Integer
Dim EndYear As Integer
Dim StartMonth As Integer
Dim EndMonth As Integer
Dim RetGross As Variant 'Tab data
Dim RetNet As Variant 'Tab data
Dim MValues As Variant 'Tab data
Dim Corner As String 'set the corner value for pasting the array
Dim ColNum As Integer 'Dynamic variable to update matrix
Dim RowNum As Integer 'Dynamic variable to update matrix
Dim First As Integer 'First row for shading - Dynamic and changing
Dim Inceptions As Variant 'Inception Dates
Dim BotRow As Integer 'Testing for Gaps
Dim TopRow As Integer 'Testing for Gaps
'Call Clearing
Workbooks("Return Formatter - Investment Metrics.xlsm").Activate
'Setting Names
ReturnWB = Sheets("Control").Range("B3") & ".xls" 'Excel Name
ReturnWBtab1 = "Pre Fee Returns" 'Tab Name
ReturnWBtab2 = "After Fee Returns" 'Tab Name
ReturnWBtab3 = "Total Fund Market Value" 'Tab Name
'Error Control
On Error GoTo Err1
'Prepping the Dates and Name
StartYear = Year(Sheets("Control").Range("B4"))
EndYear = Year(Sheets("Control").Range("B5"))
StartMonth = Month(Sheets("Control").Range("B4"))
EndMonth = Month(Sheets("Control").Range("B5"))
Months = (EndYear - StartYear + 1) * 12 - (StartMonth - 1) - (12 - EndMonth)
'Find all the unique names/managers and list them
ColACount = WorksheetFunction.CountA(Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B:B"))
'Building a Matrix
FullDataP = Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B2:E" & ColACount)
FullData = FullDataP
ReDim Preserve FullData(1 To (ColACount - 1), 1 To 5)
'Adding Start Date
FullData(1, 5) = FullData(1, 3)
For i = 2 To (ColACount - 1)
If FullData(i, 1) = FullData(i - 1, 1) Then
FullData(i, 5) = FullData(i - 1, 5)
Else
FullData(i, 5) = FullData(i, 3)
End If
Next i
ReDim Names(1 To 3, 1 To ColACount - 1) 'Setting max size
Names(1, 1) = FullData(1, 1) ' loading first value
Names(2, 1) = FullData(1, 5) ' loading first value
Names(3, 1) = 1 'Tracking the count
x = 1
For i = 1 To (ColACount - 2)
If Names(1, x) <> FullData(i + 1, 1) Then
Names(1, x + 1) = FullData(i + 1, 1)
Names(2, x + 1) = FullData(i + 1, 5)
Names(3, x + 1) = 1 'Tracking the count
x = x + 1
End If
Next i
Unique = WorksheetFunction.Sum(Application.Index(Names, 3)) 'Number of MGRs/Names
ReDim RetGross(1 To Months + 1, 1 To (Unique + 1)) 'Setting Size
ReDim Inceptions(1 To 1, 1 To (Unique + 1)) 'Setting Size
Inceptions(1, 1) = "Inception Date ->"
'Building Dates
For i = 1 To Unique
Inceptions(1, i + 1) = Names(2, i)
Next i
Corner = Sheets("ReturnsGross").Range("A2").Offset(0, Unique).Address
'Dropping Dates
Sheets("ReturnsGross").Range("A2:" & Corner) = Inceptions
'Sheets("ReturnsNet").Range("A2:" & Corner) = Inceptions
'Sheets("MarketValues").Range("A2:" & Corner) = Inceptions
RetGross(1, 1) = "Manager Name ->"
RetGross(2, 1) = WorksheetFunction.EoMonth(DateSerial(Year(Sheets("Control").Range("B4")), Month(Sheets("Control").Range("B4")), 1), 0)
'Building Dates
For i = 1 To Months - 1
RetGross(i + 2, 1) = WorksheetFunction.EoMonth(RetGross(i + 1, 1), 1)
Next i
'Building Names
For i = 1 To Unique
RetGross(1, i + 1) = Names(1, i)
Next i
'RetNet = RetGross 'These Lines will have to change
'MValues = RetGross 'These Lines will have to change
'Code to here function correctly
'Grabbing Data Gross
'Grabbing Data
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") And _
FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If

Excel: Count unique comma-delimited strings in a column with countifs-style criteria from other columns

Hoping for help form an Excel/VBA wizard on this problem. I have a possible vision of what i need, but lack the expertise to pull it off.
Essentially the problem combines the use of a countifs formula (with multiple criteria) along with counting unique strings in a column containing comma-delimited strings like this:
Criteria1 | Criteria2 |Names
A | X |Bob
B | Y |Cam;Bob
A | Y |Dan;Ava
A | Y |Ava;Cam
^In this super-simplified example, it would be like counting unique names where Criteria1 = A & criteria2 = Y. Answer = 3 (Cam, Dan, Ava)
So far, i've been able to find a VBA solution (from here)that counts unique strings in a given column like "names" above, but I don't know how to combine that with countifs-style criteria to only pass certain parts of the names range to that function.
I have created an xlsm spreadsheet that further elaborates on the problem with better sample data, expected results and the partial VBA solution I have so far:
xlsx
edit: I'm using Excel 2013
edit2: uploaded xlsx in addition to xlsm. VBA code i'm currently using is below. Note that I copied this form another source and I don't really understand how the scripting.dictionary stuff works :/
Function cntunq(ByVal rng As Range)
' http://www.mrexcel.com/forum/excel-questions/437952-counting-unique-values-seperate-comma.html
Dim cl As Range, i As Integer
Dim dic1, ar
ar = Split(Replace(Join(Application.Transpose(rng), ";"), vbLf, ""), ";")
Debug.Print Join(ar, ";")
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
For i = 0 To UBound(ar)
dic1(ar(i)) = ""
Next i
cntunq = dic1.Count
End Function
Edit3: The above code just does the counting of unique values in a given range with ;-delimited strings. The part i don't know is how to modify this to take paramArray of conditions
Here it is in a UDF using a dictionary:
Function MyCount(critRng As Range, crit As String, critRng2 As Range, crit2 As String, cntRng As Range, delim As String) As Long
Dim critarr(), critarr2(), cntarr()
Set dict = CreateObject("Scripting.Dictionary")
critarr = critRng.Value
cntarr = cntRng.Value
critarr2 = critRng2.Value
If UBound(critarr, 1) <> UBound(cntarr, 1) Then Exit Function
For i = LBound(critarr, 1) To UBound(critarr, 1)
If critarr(i, 1) = crit And critarr2(i, 1) = crit2 Then
splt = Split(cntarr(i, 1), delim)
For j = LBound(splt) To UBound(splt)
On Error Resume Next
dict.Add splt(j), splt(j)
On Error GoTo 0
Next j
End If
Next i
MyCount = dict.Count
End Function
Put that in a module and you would call it like a formula:
=MyCount($A$2:$A$5,"A",$B$2:$B$5,"Y",$C$2:$C$5,";")
Edit as per Comments
This will allow an Array entry, which will allow many conditions:
Function MyCount2(delim As String, rsltArr()) As Long
Set dict = CreateObject("Scripting.Dictionary")
Dim splt() As String
Dim i&, j&
For i = LBound(rsltArr, 1) To UBound(rsltArr, 1)
If rsltArr(i, 1) <> "False" And rsltArr(i, 1) <> "" Then
splt = Split(rsltArr(i, 1), delim)
For j = LBound(splt) To UBound(splt)
On Error Resume Next
dict.Add splt(j), splt(j)
On Error GoTo 0
Next j
End If
Next i
MyCount2 = dict.Count
End Function
This then is entered as the following array formula:
=MyCount2(";",IF(($A$2:$A$5="A")*($B$2:$B$5="Y"),$C$2:$C$5))
Being an array formula it needs to be confirmed with Ctrl-Shift-Enter when exiting edit mode instead of Enter. If done correctly then Excel will put {} around the formula.
If you want more criteria, then add another Boolean multiply to the existing in the first criterion of the IF() statement. So if you wanted to test if column Z was greater than 0 you would add * ($Z$2:$Z$5>0) after the column B test.
Here is a non array formula that uses ParamArray.
Function MyCount3(cntrng As Range, delim As String, ParamArray t()) As Long
Set dict = CreateObject("Scripting.Dictionary")
Dim cntArr As Variant
cntArr = cntrng.Value
Dim tArr() As Boolean
Dim splt() As String
Dim I&, l&
Dim tpe As String
ReDim tArr(1 To t(0).Rows.Count)
For l = 1 To t(0).Rows.Count
For I = LBound(t) To UBound(t) Step 2
If Not tArr(l) Then
If InStr("<>=", Left(t(I + 1), 1)) = 0 Then t(I + 1) = "=" & t(I + 1)
If InStr("<>=", Mid(t(I + 1), 2, 1)) > 0 Then Z = 2 Else Z = 1
tArr(l) = Application.Evaluate("NOT(""" & t(I).Item(l).Value & """" & Left(t(I + 1), Z) & """" & Mid(t(I + 1), Z + 1) & """)")
End If
Next I
Next l
For l = 1 To UBound(tArr)
If Not tArr(l) Then
splt = Split(cntArr(l, 1), delim)
For j = LBound(splt) To UBound(splt)
On Error Resume Next
dict.Add splt(j), splt(j)
On Error GoTo 0
Next j
End If
Next l
MyCount3 = dict.Count
End Function
It is entered similar to SUMIFS,COUNTIFS.
The first criterion is the range that needs to be split and counted.
The second is the delimiter on which it should split.
Then the rest is entered in pairs.
=MyCount3($C$2:$C$5,";",$A$2:$A$5,"A",$B$2:$B$5,"Y")
Consider:
Sub poiuyt()
Dim N As Long, i As Long, c As Collection
Set c = New Collection
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To N
If Cells(i, 1) = "A" And Cells(i, 2) = "Y" Then
arr = Split(Cells(i, 3), ";")
For Each a In arr
On Error Resume Next
c.Add a, CStr(a)
On Error GoTo 0
Next a
End If
Next i
MsgBox c.Count
End Sub
I took a different, possibly more complicated approach. You can specify the criteria directly on the sheet.
The function is UniqueNames(Range of Data, Range of Names, Range of Rules, Optional AndRules = True, Optional PrintNames = False)
Here is my sample sheet
I'm using the function 4 times in
- Range("E16") as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
- Range("E17") as UniqueNames(A1:F11,G1:G11,A13:B16)
- Range("F16") as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
- Range("F17") as UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)
The following operators for conditions are acceptable =,<,>,<=,>=,!=
The operator must be followed by a single space and either
- a constant value e.g. Complete
- a function of a value, e.g. Status(Project#6)
An empty condition is invalid
Here's the code: Note: There is a private function as well
Public Function UniqueNames(DataSource As Range, ResultsSource As Range, RulesSource As Range, _
Optional AndRules As Boolean = True, Optional PrintNames As Boolean = False) As String
' Return N unique names and who
' Split Indexed Expressions
Dim iChar As Integer
' Expression to eval
Dim Expression() As String
Dim expr As Variant
' Results
Dim Results As Variant
' Get Data into variant array
Dim Data As Variant
' Get Rules into variant array of NRows x 2
Dim Rules As Variant
iChar = 0
Data = DataSource
If RulesSource.Columns.Count = 1 Then
Rules = Union(RulesSource, RulesSource.Offset(0, 1))
ElseIf RulesSource.Columns.Count > 2 Then
Rules = RulesSource.Resize(RulesSource.Rows.Count, 2)
Else
Rules = RulesSource
End If
Results = ResultsSource.Resize(ResultsSource.Rows.Count, UBound(Rules))
For i = LBound(Rules) + 1 To UBound(Rules)
For j = LBound(Data, 2) To UBound(Data, 2)
If Rules(i, 1) = Data(1, j) Then
' rules must be "operator condition"
Expression = Split(Rules(i, 2), " ", 2)
Expression(1) = Trim(Expression(1))
' determine which expression is this
' Convert expression when an item of something e.g. EndDate(10)
iChar = InStr(Expression(1), "(")
If iChar > 0 Then
expr = ExprToVal(Data, Left$(Expression(1), iChar - 1), _
Mid$(Expression(1), iChar + 1, Len(Expression(1)) - iChar - 1))
Else
expr = Expression(1)
End If
For k = LBound(Data, 1) + 1 To UBound(Data, 1)
Results(k, i) = False
Select Case (Expression(0))
Case "="
If Data(k, j) <> "" And LCase$(Data(k, j)) = LCase$(expr) Then Results(k, i) = True
Case "<"
If Data(k, j) <> "" And LCase$(Data(k, j)) < LCase$(expr) Then Results(k, i) = True
Case ">"
If Data(k, j) <> "" And LCase$(Data(k, j)) > LCase$(expr) Then Results(k, i) = True
Case "<="
If Data(k, j) <> "" And LCase$(Data(k, j)) <= LCase$(expr) Then Results(k, i) = True
Case ">="
If Data(k, j) <> "" And LCase$(Data(k, j)) >= LCase$(expr) Then Results(k, i) = True
Case "!="
If Data(k, j) <> "" And LCase$(Data(k, j)) <> LCase$(expr) Then Results(k, i) = True
End Select
Next k
End If
Next j
Next i
' create one list where all three rules are true
Data = Results
Set Results = Nothing
ReDim Results(LBound(Data, 1) + 1 To UBound(Data, 1), 1 To 2) As Variant
' results now has the names w/a number representing how many rules were met
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
Results(i, 1) = Data(i, 1)
Results(i, 2) = 0
For j = LBound(Data, 2) + 1 To UBound(Data, 2)
If Data(i, j) Then Results(i, 2) = Results(i, 2) + 1
Next j
Next i
' put that back into data
Data = Results
Set Results = Nothing
Results = ""
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
If Data(i, 2) = UBound(Rules, 1) - LBound(Rules, 1) Then
Results = Results & Data(i, 1) & ";"
ElseIf AndRules = False And Data(i, 2) > 0 Then
Results = Results & Data(i, 1) & ";"
End If
Next i
' split that into expression
Expression = Split(Results, ";")
For i = LBound(Expression) To UBound(Expression)
For j = i + 1 To UBound(Expression)
If Expression(i) = Expression(j) Then Expression(j) = ""
Next j
Next i
iChar = 0
Results = ""
For i = LBound(Expression) To UBound(Expression)
If Expression(i) <> "" Then
Results = Results & Expression(i) & ";"
iChar = iChar + 1
End If
Next i
UniqueNames = ""
If PrintNames Then
' prints number of unique names and the names
UniqueNames = Results
Else
' prints number of unique names
UniqueNames = CStr(iChar)
End If
End Function
Private Function ExprToVal(Data As Variant, expr As String, Index As String) As Variant
Dim Row As Integer
Dim Col As Integer
Dim sCol As Variant
' Get what type of data this is
For i = LBound(Data, 2) To UBound(Data, 2)
sCol = Replace(Index, Data(1, i), "", 1, 1, vbTextCompare)
If IsNumeric(sCol) Then
Col = i
Exit For
ElseIf LCase$(Left$(Index, Len(Data(1, i)))) = LCase$(Data(1, i)) Then
Col = i
Exit For
End If
Next i
' now find the row of the value
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
If LCase$(Data(i, Col)) = LCase$(sCol) Then
Row = i
Exit For
End If
Next i
' find the column of the value
For i = LBound(Data, 2) To UBound(Data, 2)
If LCase$(Data(1, i)) = LCase$(expr) Then
Col = i
Exit For
End If
Next i
If Row >= LBound(Data, 1) And Row <= UBound(Data, 1) And _
Col >= LBound(Data, 2) And Col <= UBound(Data, 2) Then
ExprToVal = Data(Row, Col)
Else
ExprToVal = ""
End If
End Function