Printable View
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
OmegaboostAttachment 14857
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
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
I'd say:
Code: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
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 Attachment 14886
Why don't you adapt the datastructure ?
Hello omegaboost,
Here is the updated macro code and workbook.
Code: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
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
Structuring precedes coding....