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

OmegaboostSorting Table.xlsx

[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 Sorting Table with custom column.xlsx

[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....