Sub CondenseData_CountAndRemoveDuplicates()
'
Dim DestinationRowCounter As Long
Dim MatchCount As Long
Dim SortedArraySlot As Long
Dim SourceLastRowB As Long
Dim SourceRow As Long
Dim wsDestination2LastRowA As Long
Dim wsDestination3LastRowA As Long
Dim MatchListArray As Object
Dim RowsToDelete As String
Dim SortedArray As Variant, SortedNoDupesArray As Variant, UnsortedArray As Variant
Dim wsDestination2 As Worksheet, wsDestination3 As Worksheet, wsSource As Worksheet
'
Set wsSource = Worksheets("Sheet1") ' <--- Set this to the source sheet name
SourceLastRowB = wsSource.Range("B" & Rows.Count).End(xlUp).Row - 3 ' Get last used row -3 of Source sheet column B
'
Sheets.Add After:=Worksheets(Sheets.Count) ' Add a new sheet to end of this workbook
Set wsDestination2 = Worksheets(Sheets.Count) ' Set wsDestination2 to last sheet in workbook
'
wsDestination2.Range("A1:D1").Value = Array("Date", "Merchant", "Transaction", "Amount") ' Insert the Header for 2nd Destination Sheet
wsDestination2.Columns("A:A").NumberFormat = "m/d/yyyy" ' Format the column A of 2nd destination sheet to "m/d/yyyy"
'
DestinationRowCounter = 1 ' Initialize DestinationRowCounter
'
For SourceRow = 3 To SourceLastRowB Step 4 ' SourceRow Loop
DestinationRowCounter = DestinationRowCounter + 1 ' Increment DestinationRowCounter
'
With wsDestination2
' Copy condensed data from Source sheet to 2nd sheet
.Range("A" & DestinationRowCounter).Resize(, 4).Value = wsSource.Range("A" & SourceRow).Resize(, 4).Value
End With
Next ' Loop back
'
wsDestination2LastRowA = wsDestination2.Range("A" & Rows.Count).End(xlUp).Row ' Get last row used of sheet2 column A
'
UnsortedArray = wsDestination2.Range("A2:D" & wsDestination2LastRowA) ' Save unsorted values into 2D 1 based array RC
'
'--------------------------------------------------------------------------------------------- Start of sheet 3
'
Sheets.Add After:=Worksheets(Sheets.Count) ' Add a new sheet to end of this workbook
Set wsDestination3 = Worksheets(Sheets.Count) ' Set wsDestination3 to last sheet in workbook
'
wsDestination3.Range("A1:D1").Value = Array("Number of Charges", "Date", "Dollar Amount", "Merchant") ' Insert the Header for 3rd Destination Sheet
wsDestination3.Columns("B:B").NumberFormat = "m/d/yyyy" ' Format the column B of 3rd destination sheet to "m/d/yyyy"
wsDestination3.Range("A2:D" & wsDestination2LastRowA) = UnsortedArray ' Copy array to 3rd destination sheet
'
' RANGE SORTER ... Least important column to most important column 4,2,1
wsDestination3.Range("A2:D" & wsDestination2LastRowA).Sort Key1:=wsDestination3.Range("D2"), Order1:=xlDescending, _
Key2:=wsDestination3.Range("B2"), Order1:=xlAscending, _
Key3:=wsDestination3.Range("A2"), Order1:=xlAscending, Header:=xlNo
'
SortedArray = wsDestination3.Range("A2:D" & wsDestination2LastRowA) ' Save sorted values into 2D 1 based array RC
'
RowsToDelete = vbNullString ' Initialize RowsToDelete string to blank
'
For SortedArraySlot = UBound(SortedArray) To 2 Step -1 ' Backward loop through SortedArray
If SortedArray(SortedArraySlot, 1) = SortedArray(SortedArraySlot - 1, 1) Then ' If SortedArraySlot 1 = Previous slot then ...
If SortedArray(SortedArraySlot, 2) = SortedArray(SortedArraySlot - 1, 2) Then ' If SortedArraySlot 2 = Previous slot then ...
If SortedArray(SortedArraySlot, 3) = SortedArray(SortedArraySlot - 1, 3) Then ' If SortedArraySlot 3 = Previous slot then ...
If SortedArray(SortedArraySlot, 4) = SortedArray(SortedArraySlot - 1, 4) Then ' If SortedArraySlot 4 = Previous slot then ...
RowsToDelete = RowsToDelete & SortedArraySlot & ":" & SortedArraySlot & "," ' Save row to delete to RowsToDelete string
'
If Len(RowsToDelete) > 240 Then ' If length of RowsToDelete string > 240 then ...
If Right(RowsToDelete, 1) = "," Then ' If RowsToDelete string ends with a comma then ...
RowsToDelete = (Left(RowsToDelete, Len(RowsToDelete) - 1)) ' remove the comma from the end of the string
End If
'
wsDestination3.Range(RowsToDelete).EntireRow.Delete ' Delete all of the rows saved to RowsToDelete in one swoop
RowsToDelete = vbNullString ' Erase RowsToDelete string
End If
End If
End If
End If
End If
Next ' Loop back
'
If Len(RowsToDelete) > 0 Then ' If there are rows to delete in RowsToDelete string then ...
If Right(RowsToDelete, 1) = "," Then ' If RowsToDelete string ends with a comma then ...
RowsToDelete = (Left(RowsToDelete, Len(RowsToDelete) - 1)) ' remove the comma from the end of the string
End If
'
wsDestination3.Range(RowsToDelete).EntireRow.Delete ' Delete all of the rows saved to RowsToDelete in one swoop
RowsToDelete = vbNullString ' Erase RowsToDelete string
End If
'
wsDestination3LastRowA = wsDestination3.Range("A" & Rows.Count).End(xlUp).Row ' Get last row used of sheet3 column A
'
SortedNoDupesArray = wsDestination3.Range("A2:D" & wsDestination3LastRowA) ' Save sorted no duplicate values into 2D 1 based array RC
'
Set MatchListArray = CreateObject("System.Collections.ArrayList") ' Initialize MatchListArray
'
MatchCount = 0 ' Initialize MatchCount
'
For SortedNoDupesArraySlot = 1 To UBound(SortedNoDupesArray) ' Initialize SortedNoDupesArray loop
For SortedArraySlot = 1 To UBound(SortedArray) ' Initialize SortedNoDupesArray loop
If SortedArray(SortedArraySlot, 1) = SortedNoDupesArray(SortedNoDupesArraySlot, 1) Then
' If SortedArray slot 1 = SortedNoDupesArray slot 1 then ...
'
If SortedArray(SortedArraySlot, 2) = SortedNoDupesArray(SortedNoDupesArraySlot, 2) Then
' If SortedArray slot 2 = SortedNoDupesArray slot 2 then ...
'
If SortedArray(SortedArraySlot, 3) = SortedNoDupesArray(SortedNoDupesArraySlot, 3) Then
' If SortedArray slot 3 = SortedNoDupesArray slot 3 then ...
'
If SortedArray(SortedArraySlot, 4) = SortedNoDupesArray(SortedNoDupesArraySlot, 4) Then
' If SortedArray slot 4 = SortedNoDupesArray slot 4 then Match has been found ...
MatchCount = MatchCount + 1 ' Increment MatchCount
End If
End If
End If
End If
Next ' Loop back
'
MatchListArray.Add MatchCount ' Save MatchCount to MatchListArray
MatchCount = 0 ' Reset MatchCount
Next ' Loop back
'
wsDestination3.Range("D2:D" & wsDestination3LastRowA).Cut wsDestination3.Range("C2:C" & wsDestination3LastRowA) ' Move column D data to column C
wsDestination3.Range("B2:B" & wsDestination3LastRowA).Cut wsDestination3.Range("D2:D" & wsDestination3LastRowA) ' Move column B data to column D
wsDestination3.Range("A2:A" & wsDestination3LastRowA).Cut wsDestination3.Range("B2:B" & wsDestination3LastRowA) ' Move column A data to column B
'
wsDestination3.Range("A2").Resize(MatchListArray.Count, 1).Value = Application.Transpose(MatchListArray.ToArray) ' Display MatchListArray to column A
'
' RANGE SORTER ... Least important column to most important column 3,2,1
wsDestination3.Range("A2:D" & wsDestination3LastRowA).Sort Key1:=wsDestination3.Range("D2"), Order1:=xlAscending
wsDestination3.Range("A2:D" & wsDestination3LastRowA).Sort Key1:=wsDestination3.Range("C2"), Order1:=xlDescending
wsDestination3.Range("A2:D" & wsDestination3LastRowA).Sort Key1:=wsDestination3.Range("B2"), Order1:=xlDescending
wsDestination3.Range("A2:D" & wsDestination3LastRowA).Sort Key1:=wsDestination3.Range("A2"), Order1:=xlDescending ', Header:=xlNo
'
wsDestination3.UsedRange.EntireColumn.AutoFit ' Resize columns to fit headers/data
'
Application.DisplayAlerts = False ' Disable DisplayAlerts to stop warning
wsDestination2.Delete ' Delete sheet2
Application.DisplayAlerts = True ' Turn DisplayAlerts back on
End Sub
