Split Method: Create Header in Row 1
Dim Ws1 as long, iLoop as Long, sMonths As String, aSplitMe as Variant, aHeaderDump(1 to 1, 1 to 13) as Variant, Destination as Range
sMonths = "RepName^January^February^March^April^May^June^July^August^September^October^November^December^"
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
'Split String (Populate Public Array: Row1-Headers)
aSplitMe = Split(sMonths, "^")
'Load All non blank values into the Array (Header Position)
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
If aSplitMe(iLoop) <> "" Then aHeaderDump(1, iLoop + 1) = aSplitMe(iLoop)
Next iLoop
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
'Dump the Results (Hard Coded WS/Cell location)
'==============================================================
Worksheets(Ws1).Select
Cells.Clear
Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address)
Destination.Resize(UBound(aHeaderDump, 1), UBound(aHeaderDump, 2)).Value = aHeaderDump
'==============================================================
sMonths = "RepName^January^February^March^April^May^June^July^August^September^October^November^December^"
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
'Split String (Populate Public Array: Row1-Headers)
aSplitMe = Split(sMonths, "^")
'Load All non blank values into the Array (Header Position)
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
If aSplitMe(iLoop) <> "" Then aHeaderDump(1, iLoop + 1) = aSplitMe(iLoop)
Next iLoop
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
'Dump the Results (Hard Coded WS/Cell location)
'==============================================================
Worksheets(Ws1).Select
Cells.Clear
Set Destination = Range(Worksheets(Ws1).Cells(1, 1).Address)
Destination.Resize(UBound(aHeaderDump, 1), UBound(aHeaderDump, 2)).Value = aHeaderDump
'==============================================================
Split Method: 2 Delimiter Pairings (Set Only 1 Variant Object)
Pattern [~][ValueA][+][ValueB][~] or [|][ValueA][^][ValueB][|]
Sub MultiDelimiterSplitter()
Dim sWord As String, aSplitMe As Variant, iLoop As Long
'Pattern [~][ValueA][+][ValueB][~]
sWord = "~10+!~~20+@~~30+#~"
'Split into individual pairings:
aSplitMe = Split(sWord, "~")
'Loop through the pairings
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
'Do not review if there is no value to work with
If Len(aSplitMe(iLoop)) = 0 Then GoTo gSkipLoopNoValue
'Alternate skip method (Check for 2nd Delimiter)
'If InStr(1, aSplitMe(iLoop), "+", vbTextCompare) = 0 Then GoTo gSkipLoopNoValue
'Split the Pairing into it's Left/Right Values (Alternate:Instead of Lbound/Ubound: Use [0][1])
Debug.Print iLoop & "#= Left: " & Split(aSplitMe(iLoop), "+")(LBound(Split(aSplitMe(iLoop), "+")))
Debug.Print iLoop & "#= Right: " & Split(aSplitMe(iLoop), "+")(UBound(Split(aSplitMe(iLoop), "+")))
gSkipLoopNoValue:
Next iLoop
'Release Memory:
Set aSplitMe = Nothing
End Sub
Result:
Dim sWord As String, aSplitMe As Variant, iLoop As Long
'Pattern [~][ValueA][+][ValueB][~]
sWord = "~10+!~~20+@~~30+#~"
'Split into individual pairings:
aSplitMe = Split(sWord, "~")
'Loop through the pairings
For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
'Do not review if there is no value to work with
If Len(aSplitMe(iLoop)) = 0 Then GoTo gSkipLoopNoValue
'Alternate skip method (Check for 2nd Delimiter)
'If InStr(1, aSplitMe(iLoop), "+", vbTextCompare) = 0 Then GoTo gSkipLoopNoValue
'Split the Pairing into it's Left/Right Values (Alternate:Instead of Lbound/Ubound: Use [0][1])
Debug.Print iLoop & "#= Left: " & Split(aSplitMe(iLoop), "+")(LBound(Split(aSplitMe(iLoop), "+")))
Debug.Print iLoop & "#= Right: " & Split(aSplitMe(iLoop), "+")(UBound(Split(aSplitMe(iLoop), "+")))
gSkipLoopNoValue:
Next iLoop
'Release Memory:
Set aSplitMe = Nothing
End Sub
Result:
- 1#= Left: 10
- 1#= Right: !
- 1#= Right: !
- 3#= Left: 20
- 3#= Right: @
- 3#= Right: @
- 5#= Left: 30
- 5#= Right: #
- 5#= Right: #
Split Method: Create a Unique List using 2 Keys (Col A / Col B)
After the unique list is created, the code compares the original list against the unique list and loads a 2nd array
The second array creates a sum total based on the Concatenated Keys
'Assumptions:
'1) Objects are already defined: Ws1, Ws2, iRe1, iCe1, iSumData
'2) Keys are in Columns A & B
'3) Data to SUM is in Column defined using (iSumData)
Dim sList As String, iLoop As Long, aData() As Variant, sTemp As String, iCount As Long
Dim aSplit1 As Variant, aSplit2 As Variant
Dim R1 As Long, R2 As Long
'===================================================================================================
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'===================================================================================================
'===================================================================================================
'Create Unique list using 2 "Keys"
sList = ""
iCount = 1
For iLoop = LBound(aData) + 1 To UBound(aData)
sTemp = aData(iLoop, 1) & "|" & aData(iLoop, 2)
If InStr(1, sList, "^" & sTemp & "^", vbTextCompare) = 0 Then
sList = sList & sTemp & "^"
iCount = iCount + 1
End If
Next iLoop
'===================================================================================================
'===================================================================================================
'Load a blank Array to hold the [Split values] from the Unique List
Worksheets(Ws1).Select
aReportKey1Key2 = Range(Worksheets(Ws1).Cells(iRe1 + 1, 1).Address, Worksheets(Ws1).Cells(iRe1 + 1 + iCount, 3).Address)
'===================================================================================================
'===================================================================================================
'Load each Unique value into Array[Report(Col-1/Col2)] based on Split using 2nd delimiter ["|"]
aSplit1 = Split(sList, "^")
For iLoop = LBound(aSplit1) To UBound(aSplit1)
If aSplit1(iLoop) <> "" Then
aSplit2 = Split(aSplit1(iLoop), "|")
aReportKey1Key2(iLoop + 1, 1) = aSplit2(0)
aReportKey1Key2(iLoop + 1, 2) = aSplit2(1)
End If
Next iLoop
'===================================================================================================
'===================================================================================================
'Loop through both lists - create a sum in aReportKey1Key2(Col 3)
For R1 = LBound(aData) + 1 To UBound(aData)
For R2 = LBound(aReportKey1Key2) To UBound(aReportKey1Key2)
'Test uCase(Job) for match
If UCase(aData(R1, 1)) = UCase(aReportKey1Key2(R2, 1)) Then
'Test uCase(User) for match
If UCase(aData(R1, 2)) = UCase(aReportKey1Key2(R2, 2)) Then
'Create a sum of Time Spent - Unique to Job/User
aReportKey1Key2(R2, 3) = aReportKey1Key2(R2, 3) + aData(R1, iSumData)
End If
End If
Next R2
Next R1
'===================================================================================================
'==============================================================
Worksheets(Ws2).Select
Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aReportKey1Key2, 1), UBound(aReportKey1Key2, 2)).Value = aReportKey1Key2
'==============================================================
Erase aData: Erase aReportKey1Key2
The second array creates a sum total based on the Concatenated Keys
'Assumptions:
'1) Objects are already defined: Ws1, Ws2, iRe1, iCe1, iSumData
'2) Keys are in Columns A & B
'3) Data to SUM is in Column defined using (iSumData)
Dim sList As String, iLoop As Long, aData() As Variant, sTemp As String, iCount As Long
Dim aSplit1 As Variant, aSplit2 As Variant
Dim R1 As Long, R2 As Long
'===================================================================================================
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'===================================================================================================
'===================================================================================================
'Create Unique list using 2 "Keys"
sList = ""
iCount = 1
For iLoop = LBound(aData) + 1 To UBound(aData)
sTemp = aData(iLoop, 1) & "|" & aData(iLoop, 2)
If InStr(1, sList, "^" & sTemp & "^", vbTextCompare) = 0 Then
sList = sList & sTemp & "^"
iCount = iCount + 1
End If
Next iLoop
'===================================================================================================
'===================================================================================================
'Load a blank Array to hold the [Split values] from the Unique List
Worksheets(Ws1).Select
aReportKey1Key2 = Range(Worksheets(Ws1).Cells(iRe1 + 1, 1).Address, Worksheets(Ws1).Cells(iRe1 + 1 + iCount, 3).Address)
'===================================================================================================
'===================================================================================================
'Load each Unique value into Array[Report(Col-1/Col2)] based on Split using 2nd delimiter ["|"]
aSplit1 = Split(sList, "^")
For iLoop = LBound(aSplit1) To UBound(aSplit1)
If aSplit1(iLoop) <> "" Then
aSplit2 = Split(aSplit1(iLoop), "|")
aReportKey1Key2(iLoop + 1, 1) = aSplit2(0)
aReportKey1Key2(iLoop + 1, 2) = aSplit2(1)
End If
Next iLoop
'===================================================================================================
'===================================================================================================
'Loop through both lists - create a sum in aReportKey1Key2(Col 3)
For R1 = LBound(aData) + 1 To UBound(aData)
For R2 = LBound(aReportKey1Key2) To UBound(aReportKey1Key2)
'Test uCase(Job) for match
If UCase(aData(R1, 1)) = UCase(aReportKey1Key2(R2, 1)) Then
'Test uCase(User) for match
If UCase(aData(R1, 2)) = UCase(aReportKey1Key2(R2, 2)) Then
'Create a sum of Time Spent - Unique to Job/User
aReportKey1Key2(R2, 3) = aReportKey1Key2(R2, 3) + aData(R1, iSumData)
End If
End If
Next R2
Next R1
'===================================================================================================
'==============================================================
Worksheets(Ws2).Select
Set Destination = Range(Worksheets(Ws2).Cells(1, 1).Address)
Destination.Resize(UBound(aReportKey1Key2, 1), UBound(aReportKey1Key2, 2)).Value = aReportKey1Key2
'==============================================================
Erase aData: Erase aReportKey1Key2