Giúp code sắp sếp tên hàng theo số dòng cho trước (1 người xem)

[minhtuan55]

Mình cần 1 đoạn code sắp xếp tên hàng theo số dòng cho trước như hình bên dưới


Mong mọi người chỉ giáo. Xin chân thành cảm ơn

 

[♫ђöล♥ßล†♥†µ♫]

Mình cần 1 đoạn code sắp xếp tên hàng theo số dòng cho trước như hình bên dưới
View attachment 195438

Mong mọi người chỉ giáo. Xin chân thành cảm ơn

Sub Thu_Ti()
    Dim sRng As Range, eRng As Range, R As Long, Er As Long
    Dim sArr(), dArr(), I As Long
Er = Range("B" & Rows.Count).End(xlUp).Row
If Er > 2 Then
    Set sRng = Range("B3:B" & Er)
    Set eRng = Range("C3:C" & Er)
    R = Application.Max(eRng)
    sArr = Application.Union(sRng, eRng).Value
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 2)) And sArr(I, 2) > 0 Then dArr(sArr(I, 2), 1) = sArr(I, 1)
    Next I
    Range("I1").Resize(R) = dArr
End If
End Sub

 

[hiénlinh197]

Sub Thu_Ti()
    Dim sRng As Range, eRng As Range, R As Long, Er As Long
    Dim sArr(), dArr(), I As Long
Er = Range("B" & Rows.Count).End(xlUp).Row
If Er > 2 Then
    Set sRng = Range("B3:B" & Er)
    Set eRng = Range("C3:C" & Er)
    R = Application.Max(eRng)
    sArr = Application.Union(sRng, eRng).Value
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 2)) And sArr(I, 2) > 0 Then dArr(sArr(I, 2), 1) = sArr(I, 1)
    Next I
    Range("I1").Resize(R) = dArr
End If
End Sub

Chịu bạn bạn đấy, kiểu gì cũng nghĩ ra được thuật toán để giải.

 

[♫ђöล♥ßล†♥†µ♫]

Cái này dễ anh ạ

 

[hiénlinh197]

Cái này dễ anh ạ

hô hô ... dễ đối với bạn, nhưng khó với hàng vạn người khác bạn à.

 

[minhtuan55]

Sub Thu_Ti()
    Dim sRng As Range, eRng As Range, R As Long, Er As Long
    Dim sArr(), dArr(), I As Long
Er = Range("B" & Rows.Count).End(xlUp).Row
If Er > 2 Then
    Set sRng = Range("B3:B" & Er)
    Set eRng = Range("C3:C" & Er)
    R = Application.Max(eRng)
    sArr = Application.Union(sRng, eRng).Value
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 2)) And sArr(I, 2) > 0 Then dArr(sArr(I, 2), 1) = sArr(I, 1)
    Next I
    Range("I1").Resize(R) = dArr
End If
End Sub

Thank bác. code bác chạy Hoàn toàn Ok. bác cho em hỏi trường hợp em thay cột C bằng cột D thì sữa code ra làm sao

 

[Hoang2013]

Sub Y_Chang_Nè()
 Dim J As Long, Rw As Long, fRw As Long:        Dim Cls As Range
 Rw = [B65500].End(xlUp).Row
 ReDim Arr(1 To 65500, 1 To 1):                 fRw = Cells(3, "D").Value
1 'Chép Tên Bánh:            '
 For J = 3 To Rw
    Arr(Cells(J, "D").Value, 1) = Cells(J, "B").Value
 Next J
 Cells(fRw, "H").Resize(fRw + Cells(Rw, "C").Value).Value = Arr()
2 ' Vièn Khung:   '
 For Each Cls In Range([H1], Cells(fRw + Cells(Rw, "D").Value, "D"))
    If Cls.Value <> "" Then VienKhung Cls
 Next Cls
End Sub

Sub VienKhung(Rng As Range)
 Dim W As Long
 Rng.Select
 For W = 7 To 10
    With Selection.Borders(W)                   'xlEdgeLeft '
        .LineStyle = xlContinuous:              .Weight = xlThin
    End With
 Next W
End Sub

 

[Phuocam]

Giải trí một chút:

Sub abc()
Dim i As Long
For i = 3 To Range("D3").End(xlDown).Row
Cells(Cells(i, "D"), "H") = Cells(i, "B")
Next
End Sub

 

[PacificPR]

Cho em nghịch thêm 1 tí nữa nha (Sửa lại)

Sub Thu_Ti()
    Dim sRng As Range, eRng As Range, R As Long, Er As Long
    Dim sArr(), dArr(), I As Long
     On Error Resume Next
Er = Range("B" & Rows.Count).End(xlUp).Row
If Er > 2 Then
    Set sRng = Range("B3:B" & Er)       '****************
    Set eRng = Range("D3:D" & Er)       '****************
    R = MyMax(eRng)
    sArr = JoinArray(sRng, eRng)
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 2)) And sArr(I, 2) > 0 Then dArr(sArr(I, 2), 1) = sArr(I, 1)
    Next I
    Range("I1").Resize(R) = dArr
End If
End Sub
Function JoinArray(ParamArray arrays())
' Noi nhieu mang hoac vung thanh 1 mang
    Dim I As Long, R As Long, C As Long, aTmp, sTmp
    Dim dArr(), Iw As Long, J As Long, Jc As Long, k As Long
    On Error Resume Next
    If UBound(arrays) < 1 Then JoinArray = arrays
    If UBound(arrays) >= 1 Then
        For I = LBound(arrays) To UBound(arrays)
            aTmp = arrays(I):
            If TypeOf arrays(I) Is Range Then aTmp = arrays(I).Value
            If R <= UBound(aTmp) Then R = UBound(aTmp)
            C = C + UBound(aTmp, 2)
        Next I
        ReDim dArr(1 To R, 1 To C)
        For I = LBound(arrays) To UBound(arrays)
            aTmp = arrays(I)
            If TypeOf arrays(I) Is Range Then aTmp = arrays(I).Value
            If I > 0 Then
                sTmp = arrays(I - 1)
                If TypeOf arrays(I - 1) Is Range Then sTmp = arrays(I - 1).Value
                Jc = Jc + UBound(sTmp, 2)
            End If
            k = 0
            For Iw = 1 To UBound(aTmp)
        
                k = k + 1
                For J = 1 To UBound(aTmp, 2)
                If Not IsError(aTmp(Iw, J)) Then dArr(k, Jc + J) = aTmp(Iw, J)
                Next J
            Next Iw
        Next I
        JoinArray = dArr()
    End If
End Function

 

[befaint]

Er > 2

Ờ ha. Cái này cải cách rồi. )

Function JoinArray(ParamArray arrays())

Hình như là ở bài nối mảng (vùng) gì đó, nếu vậy nên ghi chú chủ đề (hoặc tên tác giả) thì hay hơn.

 

[PacificPR]

Ờ ha. Cái này cải cách rồi. )

Hình như là ở bài nối mảng (vùng) gì đó, nếu vậy nên ghi chú chủ đề (hoặc tên tác giả) thì hay hơn.

Cái hàm nối Range thành mảng em vừa mới làm xong đó anh ạ. Không biết có lỗi gì không

 

[befaint]

Cái hàm nối Range thành mảng em vừa mới làm xong đó anh ạ. Không biết có lỗi gì không

Function JoinArray(ParamArray arrays())... "ác man con ngan" vậy là thấy sợ rồi.
Bạn thử thêm bẫy lỗi khi trên bảng tính có lỗi (#N/A!, #DIV/0!...) xem...

 

[PacificPR]

Function JoinArray(ParamArray arrays())... "ác man con ngan" vậy là thấy sợ rồi.
Bạn thử thêm bẫy lỗi khi trên bảng tính có lỗi (#N/A!, #DIV/0!...) xem...

Trong file đính kèm em có Worksheet_Change chỉ cần gõ công thức vào 1 ô và Ctrl + Shift+Enter là xong hi hi

Public Function IsArrayEmtpy(Mang As Variant) As Boolean
    On Error GoTo XulyError
    Dim i As Integer
    i = UBound(Mang)
    IsArrayEmtpy = False
    Exit Function
XulyError:
    IsArrayEmtpy = True
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Cll, arr(), txt
On Error Resume Next
If Range(Selection.Address).HasArray Then
    Cll = Selection.Address
Else
    Exit Sub
End If
If Intersect(Target, Range(Range(Cll), Range(Cll).End(xlDown))) Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
txt = Replace(Range(Cll).Formula, "=", "")
arr = Evaluate(txt)
If IsArrayEmtpy(arr) = False Then
    If Range(Cll).HasFormula Then Range(Cll, Range(Cll).End(xlDown)).CurrentArray.ClearContents
    Range(Cll).Resize(UBound(arr), UBound(arr, 2)).FormulaArray = "=" & txt
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[PacificPR]

Function JoinArray(ParamArray arrays())... "ác man con ngan" vậy là thấy sợ rồi.
Bạn thử thêm bẫy lỗi khi trên bảng tính có lỗi (#N/A!, #DIV/0!...) xem...

Chết. Em hiểu nhầm ý anh rồi. Để em thêm bẫy lỗi vào hàm

 

[minhtuan55]

Thank bác. code bác chạy Hoàn toàn Ok

bác ơi cho em hỏi Trườn

Giải trí một chút:

Sub abc()
Dim i As Long
For i = 3 To Range("D3").End(xlDown).Row
Cells(Cells(i, "D"), "H") = Cells(i, "B")
Next
End Sub

Cảm ơn bác Giờ thì em có công thức tổng quát luôn

Code sắp sếp tên hàng theo cột và dòng cho trước

Sub codesapxep()
Dim i As Long, y As Long
For i = 3 To Range("c3").End(xlDown).Row ' tu dong 3 den dong cuoi cot c
Cells(Range("d" & i), Range("c" & i)) = Range("b" & i) ' cot C, Hang D, ten hang Cot B
Next
End Sub



Code sắp sếp tên hàng theo dòng cho trước

Sub codesapxepaa()
Dim i As Long
For i = 3 To Range("c3").End(xlDown).Row
Cells(Range("c" & i), "H") = Range("b" & i)
Next
End Sub

 

[ndu96081631]

Mọi chuyện xem như xong! Tôi xóa toàn bộ những bài không liên quan ra khỏi topic.
Còn ai muốn kiện tụng gì đó thì cứ mở topic khác nhé