Bài toán sắp xếp thứ tự 1 vùng số trên nhiều cột

[phamduylong]

Gặp bài toán này giải chưa xong. Nhờ các bạn giải giúp.
Bài toán như sau:
Một vùng có c cột, r dòng chứa n số nguyên (n<= c x r)
1 < c <= số cột của bảng tính
1<= r <= số dòng của bảng tính
(Excel 2003 có 256 cột, 65.536 dòng)
Sắp xếp lại các số vùng trên theo thứ tự từ nhỏ đến lớn, từ cột đầu đến cột cuối.
Ví dụ: 1 vùng có 3 cột, 10 dòng

|15|30
|2|5
12|6|2
21|9|8
2|5|
10|7|
1|1|4
2|3|1
20|8|3
22|2|16

Sau khi sắp xếp

1|4|15
1|5|16
1|5|20
2|6|21
2|7|22
2|8|30
2|8|
2|9|
3|10|
3|12|

 

[Po_Pikachu]

Code cùi bắp như vậy được không bác?

Sub sort()
Dim t As String, d As Byte, c As Byte
d = 10
c = 3
For j = 1 To c
For i = 1 To d
    For n = 1 To c
    For m = 1 To d
        If Cells(m, n) = "" Then Cells(m, n) = " "
        If Cells(i, j) < Cells(m, n) Then
        t = Cells(i, j)
        Cells(i, j) = Cells(m, n)
        Cells(m, n) = t
        End If
    Next m, n
Next i, j
End Sub

Thân.

 

[SA_DQ]

Thầy dùng thử cái ni, fương thức tìm kiếm

Option Explicit
Sub XepTheoCot()
 Dim Rng As Range, sRng As Range, Rng0 As Range
 Dim MyAdd As String
 Dim Jj As Long, Col As Byte, Rws As Long, MaX_ As Long, Min_ As Long
 Dim xX As Long, yY As Byte
 
 Set Rng = Application.InputBox("Hay Chon Vung Khao Sat:", Type:=8)
 Col = Rng.Columns.Count:              Rws = Rng.Rows.Count
 With Application.WorksheetFunction
   MaX_ = .Max(Rng):             Min_ = .Min(Rng)
 End With
 Set Rng0 = Rng.Cells(1, 1).Offset(, Col + 2)
 xX = 0:                         yY = 0
 For Jj = Min_ To MaX_
   Set sRng = Rng.Find(Jj, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address
      Do
         xX = xX + 1
         If xX > Rws Then
            xX = 1:        yY = yY + 1
         End If
         Rng0.Cells(xX, yY).Value = sRng.Value
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
   End If
 Next Jj
End Sub

 

[ThuNghi]

Em thì dùng countif, hy vọng nhanh hơn Find.
Có thể cải tiến gán 1 mảng là 1 số i, nhưng tính lại cột và dòng chưa ra.
Dạng như
SoLan=Z
Range(Cells(fR,FC1), Cells(fR+Z,FC2))=i

Option Explicit
Sub sapxep()
Dim iSo As Long, iMax As Long, iMin As Long, endR As Long
Dim soDong As Long, iSolan As Long, i As Long, Xx As Long, Yy As Long, k As Long
Dim myRng As Range
Dim wf As WorksheetFunction
Const soCot As Long = 3
Set wf = WorksheetFunction
Sheet1.Select
Range("E1:F10").ClearContents
Set myRng = Range("A1:C10")
iSo = wf.CountIf(myRng, ">0")
iMax = wf.Max(myRng)
iMin = wf.Min(myRng)
soDong = wf.RoundUp(iSo / soCot, 0)
Yy = 5
Xx = 1
For i = iMin To iMax
  iSolan = wf.CountIf(myRng, i)
  If iSolan > 0 Then
    For k = 1 To iSolan
      If Xx > soDong Then
        Xx = 1
        Yy = Yy + 1
        Cells(Xx, Yy) = i
      Else
        Cells(Xx, Yy) = i
        Xx = Xx + 1
      End If
    Next
  End If
Next
End Sub

 

[phamduylong]

Tôi thêm 1 biến đếm vào các vòng lặp để ghi nhận số lần lặp. Kết quả như sau:
Po_pikachu:
code rất gọn, xếp trực tiếp ngay trên vùng. Số lần lặp phụ thuộc vào số ô (15 ô: 288, 30 ô: 1023, 60 ô: 3843, 90 ô: 8463), không phụ thuộc vào giá trị max, min của dữ liệu. Số ô càng nhiều thì số vòng lặp tăng theo.
SA_DQ, ThuNghi:
Mặc dù 2 cách viết khác nhau nhưng số lần lặp giống nhau.
Dữ liệu 15 ô, Min=1 Max=10: lặp 25 lần
Dữ liệu 15 ô, Min=1 Max=1.000.000: lặp 1.000.015 lần
Dữ liệu 30 ô, Min=1 Max=1.000.000: lặp 1.000.030 lần
Nó phụ thuộc vào Min, Max. Giá trị Max-Min càng nhỏ thì càng nhanh. Còn chênh lệch quá lớn thì dù dữ liệu ít nhưng lặp rất nhiều (số lần lặp= Max-Min + số ô)

Mình tham khảo các cách viết. Mong nhận thêm cách giải của các bạn.

 

[rollover79]

Tôi thêm 1 biến đếm vào các vòng lặp để ghi nhận số lần lặp. Kết quả như sau:
Po_pikachu:
code rất gọn, xếp trực tiếp ngay trên vùng. Số lần lặp phụ thuộc vào số ô (15 ô: 288, 30 ô: 1023, 60 ô: 3843, 90 ô: 8463), không phụ thuộc vào giá trị max, min của dữ liệu. Số ô càng nhiều thì số vòng lặp tăng theo.
SA_DQ, ThuNghi:
Mặc dù 2 cách viết khác nhau nhưng số lần lặp giống nhau.
Dữ liệu 15 ô, Min=1 Max=10: lặp 25 lần
Dữ liệu 15 ô, Min=1 Max=1.000.000: lặp 1.000.015 lần
Dữ liệu 30 ô, Min=1 Max=1.000.000: lặp 1.000.030 lần
Nó phụ thuộc vào Min, Max. Giá trị Max-Min càng nhỏ thì càng nhanh. Còn chênh lệch quá lớn thì dù dữ liệu ít nhưng lặp rất nhiều (số lần lặp= Max-Min + số ô)

Mình tham khảo các cách viết. Mong nhận thêm cách giải của các bạn.

Xin góp vui 1 đoạn code, tôi dùng màng tạm và sắp xếp trên mảng tạm đó, sau đó gán ngược lại vùng, code sắp xếp trên vùng được chọn, và giả định toàn bộ đều có giá trị kiểu số nguyên.

Sub Sort()
    Dim rng As Range
    Set rng = Selection
    Dim rowNo As Long, colNo As Long, iMax As Long
    colNo = rng.Rows.Count
    rowNo = rng.Columns.Count
    iMax = WorksheetFunction.Max(rng) + 1
    rng.Replace Empty, iMax
    Dim arr
    arr = WorksheetFunction.Transpose(rng)
    Dim i As Long, jRow As Long, jCol As Long, temp, iRow As Long, iCol As Long
    For i = 0 To rowNo * colNo - 1
        For j = i + 1 To rowNo * colNo - 1
            iRow = (i \ colNo) + 1
            iCol = (i Mod colNo) + 1
            jRow = (j \ colNo) + 1
            jCol = (j Mod colNo) + 1
            If arr(iRow, iCol) > arr(jRow, jCol) Then
                temp = arr(iRow, iCol)
                arr(iRow, iCol) = arr(jRow, jCol)
                arr(jRow, jCol) = temp
            End If
        Next
    Next
    rng.Value = WorksheetFunction.Transpose(arr)
    rng.Replace iMax, Empty
End Sub

Đoạn code của tôi thì số vòng lặp phụ thuộc vào số lượng ô trong vùng, tốc độ xử lý sẽ là không thay đổi với mỗi vùng cụ thể.

 

[ThuNghi]

Vậy em tính triển khai theo hướng

for i = 1 to TS (tổng số các số >0; wf.CountIf(myRng, ">0"))
if so=so01 then goto tiep
so=wf.small(myRng,so)
...
so1=so
tiep:
next

Như vậy sẽ giảm số vòng lặp và kg phân biệt chênh lệch max và min mà chỉ lấy theo tổng các số hạng.
Thầy test giúp em thử.
Cám ơn Thầy.

 

[ThuNghi]

Em dùng tạm khai name Data cho dễ, nếu OK em sẽ hoàn thiện tiếp. Thầy giúp em test nhé.
Code này số lần vòng lặp chỉ là số tổng số hạng duy nhất. Còn số đó mà có xuất hiện nhiều lần thì sẻ thay tiếp cái vòng lặp đó nữa, lúc đó sẽ tính đến dòng mới và cột mới.

Option Explicit
Sub sapxepTN()
Dim iSo As Long, iMin As Long
Dim soDong As Long, SoLan As Long, i As Long, Xx As Long, Yy As Long, k As Long
Dim wf As WorksheetFunction
Const soCot As Long = 3
Dim myRng As Range
Set wf = WorksheetFunction
Sheet1.Select
Range("E1:F10").ClearContents
Set myRng = Range("A1:C10")
iSo = wf.CountIf(myRng, ">0")
soDong = wf.RoundUp(iSo / soCot, 0)
Yy = 5
Xx = 1
i = 1
Do While i <= iSo
    iMin = wf.Small(myRng, i)
    SoLan = wf.CountIf(myRng, iMin)
    i = i + SoLan
    If SoLan > 0 Then
      For k = 1 To SoLan
        If Xx > soDong Then
          Xx = 1
          Yy = Yy + 1
          Cells(Xx, Yy) = iMin
        Else
          Cells(Xx, Yy) = iMin
          Xx = Xx + 1
        End If
      Next
  End If
Loop
Set myRng = Nothing
End Sub

Cái vụ xđ cột mới và dòng mới để khỏi for k này em chưa làm xong.
Vì gán 1 vùng xác định = 1 số n thì cũng không cần phải for k.
Thầy giúp em làm tiếp, hay là có cách gì gán vào 1 array và array đó tự động gán vào 1 range theo unbound(array).