Sort data without changing the set of each data (using VBA)

[feni1388]

Hello everyone...
I have data that needs to be sorted based on date and its number of occurance.
The user copy and paste one set of data one by one using VBA. So the date is random. Can be 2024/6/12 at the end of the rows or perhaps in the middle.
So I need to sort it first by date and then the number of occurance. But I still can't find a way to sort it without changing the set of each data.
I don't know how to do it manually, let alone using VBA.
Any idea how to do this?
Please help.

Book1
	A	B	C	D	E	F
1	Date	Customer code	No. of items	Item code	Qty	Number of occurance
2	2024/6/14	CHO01018	1	GH07	10	1
3			2	GL78	1
4			3	GH73	1
5	2024/6/13	CMX01027	1	GH07	10	1
6			2	GL78	1
7			3	GH73	1
8			4	GL83	2
9	2024/6/14	CNB01064	1	BM43	15	2
Sheet1

Cell Formulas
Range	Formula
C2,C5,C9	C2	=IFERROR(IF(D2<>"",1,""),"")
C3:C4,C6:C8	C3	=IF(D3="","",IF(AND(D3<>"",C2=""),1,C2+1))
F2:F9	F2	=IF(A2="","",IF(A2=A2,COUNTIF($A$2:A2,A2),""))

I want it to be like below

Book1
	A	B	C	D	E	F
1	Date	Customer code	No. of items	Item code	Qty	Number of occurance
2	2024/6/14	CHO01018	1	GH07	10	1
3			2	GL78	1
4			3	GH73	1
5	2024/6/14	CNB01064	1	BM43	15	2
6	2024/6/13	CMX01027	1	GH07	10	1
7			2	GL78	1
8			3	GH73	1
9			4	GL83	2
Sheet1

Cell Formulas
Range	Formula
C2,C5:C6	C2	=IFERROR(IF(D2<>"",1,""),"")
C3:C4,C7:C9	C3	=IF(D3="","",IF(AND(D3<>"",C2=""),1,C2+1))
F2:F9	F2	=IF(A2="","",IF(A2=A2,COUNTIF($A$2:A2,A2),""))

 

[Fuji]

try

Sub test()
    Dim a, e, i&, ii&, n&, temp, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With [a1].CurrentRegion
        a = .FormulaR1C1
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then temp = a(i, 1)
            If Not dic.exists(temp) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = dic(temp)
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            dic(temp) = w
        Next
        mySort dic
        ReDim a(1 To UBound(a, 1), 1 To UBound(a, 2))
        For Each e In dic
            For ii = 1 To UBound(dic(e), 2)
                n = n + 1
                For i = 1 To UBound(dic(e), 1)
                    a(n, i) = dic(e)(i, ii)
                Next
            Next
        Next
        .Rows(2).Resize(n) = a
    End With
End Sub

Sub mySort(dic As Object)
    Dim i As Long, ii As Long, temp
    For i = 0 To dic.Count - 2
        For ii = i + 1 To dic.Count - 1
            If UBound(dic.items()(i), 2) > UBound(dic.items()(ii), 2) Then
                temp = dic.items()(i)
                dic.items()(i) = dic.items()(ii)
                dic.items()(ii) = temp
            End If
        Next
    Next
End Sub

 

[feni1388]

try

Sub test()
    Dim a, e, i&, ii&, n&, temp, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With [a1].CurrentRegion
        a = .FormulaR1C1
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then temp = a(i, 1)
            If Not dic.exists(temp) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = dic(temp)
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            dic(temp) = w
        Next
        mySort dic
        ReDim a(1 To UBound(a, 1), 1 To UBound(a, 2))
        For Each e In dic
            For ii = 1 To UBound(dic(e), 2)
                n = n + 1
                For i = 1 To UBound(dic(e), 1)
                    a(n, i) = dic(e)(i, ii)
                Next
            Next
        Next
        .Rows(2).Resize(n) = a
    End With
End Sub

Sub mySort(dic As Object)
    Dim i As Long, ii As Long, temp
    For i = 0 To dic.Count - 2
        For ii = i + 1 To dic.Count - 1
            If UBound(dic.items()(i), 2) > UBound(dic.items()(ii), 2) Then
                temp = dic.items()(i)
                dic.items()(i) = dic.items()(ii)
                dic.items()(ii) = temp
            End If
        Next
    Next
End Sub

Wow..........Thank you.... it's very close, except June 13th became at the end instead of the beginning.
I tried to undertand the code and change it myself, but it's really beyond me.
Which part should I change to make it right?

Book1
	A	B	C	D	E	F
1	Date	Customer code	No. of items	Item code	Qty	Number of occurance
2	2024/6/14	CHO01018	1	GH07	10	1
3			2	GL78	1
4			3	GH73	1
5	2024/6/14	CNB01064	1	BM43	15	2
6	2024/6/13	CMX01027	1	GH07	10	1
7			2	GL78	1
8			3	GH73	1
9			4	GL83	2
Sheet1

Cell Formulas
Range	Formula
F2:F9	F2	=IF(A2="","",IF(A2=A2,COUNTIF($A$2:A2,A2),""))

 

[Fuji]

???
The result shows exactly the same as your result in your post #1.(2nd table)
Am I missing something?

 

[feni1388]

???
The result shows exactly the same as your result in your post #1.(2nd table)
Am I missing something?

Sorry.........sorry....... I got completely confused. You're right.
I mixed it up with getting the data ascending instead of descending.
Your current code it's alright..... Thank you so much.....

 

[feni1388]

I did another test again. It seems that I need to separate the first code and your code.
If there's a way to combine it, it'd be great.

 

[Fuji]

Do you mean "Sub CopyData"?
try change
1)

Dim LastRow As Long

Sheets("Searh").Select
Range("C6:G31").Select
Selection.Copy


LastRow = Sheets("NextPO").Cells(Rows.Count, "D").End(xlUp).Row
LastRow = LastRow + 1
Sheets("NextPO").Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

to

Sheets("Searh").Range("C6:G31").Copy
Sheets("NextPO").Range("A1").PasteSpecial xlValues

2) delete

            Range("F:F").Value = Range("F:F").Value

And see how it goes.

 

[feni1388]

Thank you once again.
It works well.

 

[feni1388]

try

Sub test()
    Dim a, e, i&, ii&, n&, temp, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With [a1].CurrentRegion
        a = .FormulaR1C1
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then temp = a(i, 1)
            If Not dic.exists(temp) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = dic(temp)
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            dic(temp) = w
        Next
        mySort dic
        ReDim a(1 To UBound(a, 1), 1 To UBound(a, 2))
        For Each e In dic
            For ii = 1 To UBound(dic(e), 2)
                n = n + 1
                For i = 1 To UBound(dic(e), 1)
                    a(n, i) = dic(e)(i, ii)
                Next
            Next
        Next
        .Rows(2).Resize(n) = a
    End With
End Sub

Sub mySort(dic As Object)
    Dim i As Long, ii As Long, temp
    For i = 0 To dic.Count - 2
        For ii = i + 1 To dic.Count - 1
            If UBound(dic.items()(i), 2) > UBound(dic.items()(ii), 2) Then
                temp = dic.items()(i)
                dic.items()(i) = dic.items()(ii)
                dic.items()(ii) = temp
            End If
        Next
    Next
End Sub

Sorry to bother you again.

Your code was working fine and suddenly from yesterday it doesn't work as you can see from the table below.
I tried to look for the cause, but I still can't find any.
Maybe you have something in mind that might cause it.

I tried adding a record and it added to the correct place, but it didn't sort the whole record at the end.

Book2
	A	B	C	D	E	F
1	Date	Customer code	No. of items	Item code	Qty	Number of occurance
2	2024/6/25	FMS01010	1	GL44	5	1
3			2	GL43	2
4	2024/6/25	SBD04063	1	JS14	1	2
5			2	JS20	7
6	2024/6/25	KYS01011	1	GL99	40	3
7			2	GL44	20
8	2024/6/25	SBD02A03	1	GL91	10	4
9	2024/6/25	NKK01001	1	BM44	1	5
10			2	GH23	1
11			3	GL07	1
12			4	GM74	2
13	2024/6/25	KSS01068	1	KJ10	1	6
14	2024/6/25	FMS01010	1	GL44	5	7
15			2	GL43	2
16	2024/6/25	SBD04063	1	JS14	1	8
17			2	JS20	7
18	2024/6/25	SMJ02371	1	GL43	3	9
19	2024/6/26	MFJ01004	1	GK93	3	1
20	2024/6/26	TKH01086	1	JS11	3	2
21	2024/6/26	SSS01801	1	BM93	1	3
22	2024/6/26	MRE02006	1	BM43	30	4
23	2024/6/26	SSS01B16	1	JT09	1	5
24	2024/7/1	KOG06006	1	MX73	6	1
25			2	MX45	1
26	2024/7/1	AES03095	1	GL23	10	2
27	2024/7/1	MGS01002	1	JS17	5	3
28	2024/7/1	KOU01017	1	BM73	18	4
29	2024/7/3	KOU01007	1	GL07	1	1
30	2024/7/3	MFJ01004	1	GK93	3	2
31	2024/7/3	RUG03039	1	GA02	30	3
32	2024/7/4	RUG04035	1	JT12	12	1
33	2024/6/28	MRW01020	1	GS93	1	1
34			2	GL48	1
35	2024/6/28	TKN01018	1	BM43	1	2
36	2024/6/28	NEC01015	1	TU35	1	3
37			2	TU50	1
Sheet2

 

[Fuji]

Ahhh,
This should do.

Sub test()
    Dim a, i&, temp
    Application.ScreenUpdating = False
    a = Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(a, 1)
        If a(i, 1) <> "" Then temp = CLng(a(i, 1))
        a(i, 1) = temp + i / (UBound(a, 1) * 100)
    Next
    Columns(1).Insert
    Columns(1).NumberFormat = ""
    [a2].Resize(UBound(a, 1)) = a
    [a1].CurrentRegion.Sort [a1], 1, , , , , , 1
    Columns(1).Delete
    Application.ScreenUpdating = True
End Sub