VBA for Sorting Table

[omegaboost]

Dear All,

How to make the VBA for the sorting data from Input Table with there is no duplication and make the total for each Code. The sorting data will be like in sorting table.

for the further details I attach the file.

Thank you

Omegaboost14857

[Leith Ross]

Hello VBAX Newbie,

This was a rather complex sorting operation. I rewrote this macro four times to make it easy to allow for more code columns and keep it fast. The macros below have been added to the attached workbook along with a button to run the main macro.

The sorted data is output the "Sorting Table". The macro can be changed to output the sorted data anywhere in the workbook. With a slight modification, the sorted data can overwrite the original data if needed.

Module1 Macro Code


Private TableRng As Range

Public Sub SortData()

Dim Cell As Range
Dim colCount As Long
Dim Data As Variant
Dim EntryData As Variant
Dim EntryDates As New Collection
Dim j As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim RngOut As Range
Dim Wks As Worksheet


' Save the Table's range of cells in the object variable TableRng.
Set Wks = Worksheets("Sheet1")

Set RngBeg = Wks.Range("A4:E4")
Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)

If RngEnd.Row < RngBeg.Row Then Exit Sub

Set TableRng = Wks.Range(RngBeg, RngEnd)

Application.ScreenUpdating = False

Set RngOut = Wks.Range("H4:L4")
colCount = RngOut.Columns.Count

' Create a collection of unique Entry Dates.
For Each Cell In TableRng.Columns(1).Cells
On Error Resume Next
EntryDates.Add Cell.Value, Cell.Text
On Error Resume Next
Next Cell

For Each EntryDate In EntryDates
Data = GetDataByDate(EntryDate)
RngOut.Cells(1, 1).Resize(RowSize:=UBound(Data, 1) + 1).Value = EntryDate
For j = 0 To UBound(Data, 1)
RngOut.Offset(j, 1).Resize(1, colCount - 1).Value = Data(j)
Next j
Set RngOut = RngOut.Offset(j, 0)
Next EntryDate

Application.ScreenUpdating = True

End Sub


Private Function GetDataByDate(ByVal EntryDate As Date)

Dim Amount1 As Long
Dim Amount2 As Long
Dim c As Variant
Dim Cell As Range
Dim colArray As Variant
Dim Data As Variant
Dim Dict As Object
Dim Key As Variant
Dim n As Long
Dim r As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim Wks As Worksheet

'EntryDate = DateValue("December 01, 2015")

' Relative Amount column numbers in the table. The last 2 rightmost columns.
Amount2 = TableRng.Columns.Count
Amount1 = Amount2 - 1

' Relative Table column numbers for the Date, Code1, and Code2. More Code columns can be added if needed.
colArray = Array(1, 2, 3)

Set Dict = CreateObject("Scripting.Dictionary")

' Check each Code column for matching dates.
For c = 1 To UBound(colArray)
For Each Cell In TableRng.Columns(colArray(0)).Cells
If Cell = EntryDate Then
' Convert absolute Worksheet row number to relative Table row number.
r = Cell.Row - TableRng.Row + 1
Key = Trim(TableRng.Cells(r, colArray(c)))
If Key <> "" Then
If Not Dict.Exists(Key) Then
' Create a new output array for the code.
ReDim Data(3)
Select Case c
Case 1: Data(0) = Key: Data(1) = Empty
Case 2: Data(0) = Empty: Data(1) = Key
End Select
Data(2) = TableRng.Cells(r, Amount1).Value
Data(3) = TableRng.Cells(r, Amount2).Value
Dict.Add Key, Data
Else
' Accumulate the amount columns for the code.
Data = Dict(Key)
Data(2) = Data(2) + TableRng.Cells(r, Amount1).Value
Data(3) = Data(3) + TableRng.Cells(r, Amount2).Value
Dict(Key) = Data
End If
End If
End If
Next Cell
Next c

' Return a Variant Array of all Codes and Amounts for the given date.
GetDataByDate = Dict.Items

End Function

[snb]

I'd say:


Sub M_snb()
sn = Sheet1.Cells(4, 1).CurrentRegion

With CreateObject("scripting.dictionary")
For j = 3 To UBound(sn)
c00 = sn(j, 1) & "_" & sn(j, 2) & sn(j, 3)
If .exists(c00) Then
sp = .Item(c00)
sp(3) = sp(3) + sn(j, 4)
sp(4) = sp(4) + sn(j, 5)
Else
sp = Array(1 * CDate(sn(j, 1)), sn(j, 2), sn(j, 3), sn(j, 4), sn(j, 5))
End If
.Item(sn(j, 1) & "_" & sn(j, 2) & sn(j, 3)) = sp
Next

Sheet1.Cells(20, 1).Resize(.Count, 5) = Application.Index(.items, 0, 0)
End With
End Sub

[omegaboost]

Dear All,
Once again thank you for kind response. Just need more favor to how to modify the VBA code in case the column for Amount 1 and Amount2 in the Input Table is located not next to each other and also in Sorting Table columns are not located next to each other. In terms of how to customize the layout of the column in VBA code as in the file (attached).

Thank you

Omegaboost 14886

[snb]

Why don't you adapt the datastructure ?

[Leith Ross]

Hello omegaboost,

Here is the updated macro code and workbook.



Private TableRng As Range

Public Sub SortData()

Dim Cell As Range
Dim colCount As Long
Dim colOutput As Variant
Dim Data As Variant
Dim EntryData As Variant
Dim EntryDates As New Collection
Dim j As Long
Dim n As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim RngOut As Range
Dim Wks As Worksheet


' Save the Table's range of cells in the object variable TableRng.
Set Wks = Worksheets("Sheet1")

Set RngBeg = Wks.Range("A4:G4")
Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)

If RngEnd.Row < RngBeg.Row Then Exit Sub

' Offsets from first cell in Table to the Output Columns.
colOutput = Array(0, 1, 2, 6, 9) ' Date, Code1, Code2, Amount1, Amount2

Set TableRng = Wks.Range(RngBeg, RngEnd)

Application.ScreenUpdating = False

Set RngOut = Wks.Range("J4:S4")
colCount = RngOut.Columns.Count

' Create a collection of unique Entry Dates.
For Each Cell In TableRng.Columns(1).Cells
On Error Resume Next
EntryDates.Add Cell.Value, Cell.Text
On Error Resume Next
Next Cell

For Each EntryDate In EntryDates
Data = GetDataByDate(EntryDate)
RngOut.Cells(1, 1).Resize(RowSize:=UBound(Data, 1) + 1).Value = EntryDate
For j = 0 To UBound(Data, 1)
n = 0
For k = 1 To UBound(colOutput)
RngOut.Cells(j + 1, 1).Offset(0, colOutput(k)).Value = Data(j)(n)
n = n + 1
Next k
Next j
Set RngOut = RngOut.Offset(j, 0)
Next EntryDate

Application.ScreenUpdating = True

End Sub


Private Function GetDataByDate(ByVal EntryDate As Date)

Dim Amount1 As Long
Dim Amount2 As Long
Dim c As Variant
Dim Cell As Range
Dim colArray As Variant
Dim Data As Variant
Dim Dict As Object
Dim Key As Variant
Dim n As Long
Dim r As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim Wks As Worksheet

'EntryDate = DateValue("December 01, 2015")

' Relative Amount column numbers in the table. The last 2 rightmost columns.
Amount2 = TableRng.Columns.Count
Amount1 = Amount2 - 2

' Relative Table column numbers for the Date, Code1, and Code2. More Code columns can be added if needed.
colArray = Array(1, 2, 3)

Set Dict = CreateObject("Scripting.Dictionary")

' Check each Code column for matching dates.
For c = 1 To UBound(colArray)
For Each Cell In TableRng.Columns(colArray(0)).Cells
If Cell = EntryDate Then
' Convert absolute Worksheet row number to relative Table row number.
r = Cell.Row - TableRng.Row + 1
Key = Trim(TableRng.Cells(r, colArray(c)))
If Key <> "" Then
If Not Dict.Exists(Key) Then
' Create a new output array for the code.
ReDim Data(3)
Select Case c
Case 1: Data(0) = Key: Data(1) = Empty
Case 2: Data(0) = Empty: Data(1) = Key
End Select
Data(2) = TableRng.Cells(r, Amount1).Value
Data(3) = TableRng.Cells(r, Amount2).Value
Dict.Add Key, Data
Else
' Accumulate the amount columns for the code.
Data = Dict(Key)
Data(2) = Data(2) + TableRng.Cells(r, Amount1).Value
Data(3) = Data(3) + TableRng.Cells(r, Amount2).Value
Dict(Key) = Data
End If
End If
End If
Next Cell
Next c

' Return a Variant Array of all Codes and Amounts for the given date.
GetDataByDate = Dict.Items

End Function

[omegaboost]

Dear All,

Thank you for the helping. To answer why I did not adapt the data structure is because I want to learn to be able to understand the code further and if one day there is the same problem, I can handle it. Of course the first thing I do is create a data structure in accordance with the code.

Best Regards
Omegaboost

[snb]

Structuring precedes coding....