Sắp xếp lấy TOP 4 theo nhiều điều kiện

[HUONGHCKT]

Dạ mong anh bỏ quá cho, không biết nói gì ngoài Cảm ơn Anh. Chúc Anh luôn mạnh khoẻ và Thành đạt!!!

Bạn có giận tôi thì giân, chứ tôi có lý do gì giân bạn đâu mà phải bỏ quá cho ?

 

[tranhoainam9701]

Tôi chỉ muốn nhắc bạn ấy là nếu sử dụng file tôi để tính toán lô đề, cờ bạc gửi thì hãy cảnh giác (có thể sẽ phải ra đê để ở...). Vì có thể sẽ không đem lại kết quả sau cùng như mong muốn.
Còn bạn ấy có hiểu hay không hiểu thì bạn ấy cứ đọc hết các bài thì cũng có thể hiểu được code vô tư hay không vô tư.

Dạ Anh.. Cám ơn Anh vì sự giúp đỡ vô tư. Quả thực là vậy vì bài này mà làm Anh mất quá nhiều thời gian vì nội dung em đưa ra khiến anh không hiểu. Lẽ ra em nên viết là đếm kí từ phải qua trái đối với các dòng có bôi màu cùng hàng khi gặp ô không cùng hàng thì dừng lại và trả kết quả số lần... và đối với ô không có màu thì ngược lại. Dạ đó là lỗi phía em, văn phạm lủng củng làm Anh toàn phải đoán nội dung để code. Một lần nữa chúc Anh và Các Anh/ Chị trên diễn đàn luôn mạnh khoẻ, hạnh phúc, thành công!!
Xin cám ơn tất cả mọi người đã quan tâm giúp đỡ!
Trân trọng/

Bài đã được tự động gộp: 10/3/22

Bạn có giận tôi thì giân, chứ tôi có lý do gì giân bạn đâu mà phải bỏ quá cho ?

thì cũng tại em diễn đạt không chuẩn, làm mất thời gian code đi code lại ý mà. Nếu không phiền Anh có thể cho em xin số điện thoại để tiện liên lạc ak!

 

[tranhoainam9701]

Chạy 2 code . . .

Option Explicit
Sub Dem()
  Dim arr(), S, res(), str$, tmp$, t$, a$, d$
  Dim sR&, i&, k&, j&, N&, fC&, c&
  Const deli$ = ",.;:-"
  With Sheet1
    arr = .Range("A2", .Range("A2").End(xlDown)).Value
  End With
  sR = UBound(arr)
  ReDim res(1 To sR, 1 To 3)
  For i = 1 To sR
    str = Replace(arr(i, 1), " ", "") & ","
    N = Len(str)
    fC = 1
    k = 0
    tmp = "|"
    a = Empty: d = Empty
    For j = 1 To N
      c = InStr(1, deli, Mid(str, j, 1))
      If c > 0 Then
        t = Mid(str, fC, j - fC)
        If InStr(1, tmp, "|" & t & "|") = 0 Then
          k = k + 1
          tmp = tmp & t & "|"
          a = a & d & t
          d = Mid(deli, c, 1)
        End If
        fC = j + 1
      End If
    Next j
    If a = Empty Then res(i, 1) = str Else res(i, 1) = a
    res(i, 2) = k
  Next i
  Sheet1.Range("B2").Resize(sR).NumberFormat = "@"
  Sheet1.Range("B2").Resize(sR, 2) = res
End Sub

Sub Them()
  Dim arr(), res(), sR&, sC&, i&, j&

  arr = Sheet1.Range("E2:N2").Resize(10).Value
  sR = UBound(arr, 1): sC = UBound(arr, 2)
  For j = 1 To sC
    For i = 2 To sR
      If arr(i - 1, j) = 9 Then arr(i, j) = 0 Else arr(i, j) = arr(i - 1, j) + 1
    Next i
  Next j
  Sheet1.Range("E2:N2").Resize(10).Value = arr
End Sub

Em xin chân thành cám ơn Thầy nhiều! Xin chúc Thầy luôn mạnh khoẻ và vui.
Trân trọng/

Bài đã được tự động gộp: 10/3/22

Đúng như Anh@ Hoàng Tuấn 868 chuẩn đoán, khai vừa thiếu biến vừa thừa biến.
Bạn thay lại code cũ bằng code này.

Option Explicit

Sub XYZ2()
Dim i&, j&, t&, k&, Z&, M&, Comau&, Kmau&, Lr&, Col&
Dim eRng As Range, Sh As Worksheet
Dim Arr(), KQK(), KQM(), SoLan(), TieudeC(), TieudeK()
Dim Dic As Object, Key
Dim Ketqua As Range

Application.ScreenUpdating = False

On Error Resume Next
Set Sh = Sheet1
Lr = Sh.Cells(Rows.Count, 1).End(xlUp).Row

ReDim KQM(1 To Lr - 3, 1 To 100)
ReDim KQK(1 To Lr - 3, 1 To 100)
ReDim TieudeC(1 To 1, 1 To 100)
ReDim TieudeK(1 To 1, 1 To 100)
For i = 4 To Lr
t = t + 1
Set eRng = Sh.Range(Cells(i, 1), Cells(i, Sh.Range("A" & i).End(xlToRight).Column))
Col = eRng.Columns.Count
    For j = Col To 1 Step -1
        If eRng(1, j) <> Empty Then
            If eRng(1, j).Interior.Color = vbYellow Then
                Comau = Comau + 1
            Else
               Kmau = Kmau + 1
                If Comau >= 1 Then Exit For
            End If
        End If
    Next j
        TieudeC(1, Comau) = "Liên tuc có màu liên tiêp " & Comau
        TieudeK(1, Kmau - 1) = "Liên tuc không có màu liên tiêp " & Kmau - 1
            KQM(t, Comau) = eRng(1, Col)
            KQK(t, Kmau - 1) = eRng(1, Col)
    If Comau > M Then M = Comau
       Comau = 0: Kmau = 0: Set Rng = Nothing
Next i

Sh.[J1].Resize(10000, 1000).ClearContents
Sh.[J1].Resize(1, M) = TieudeC
Sh.[J1].Resize(2, M).Interior.Color = vbYellow
Sh.[J1].Offset(0, M).Resize(1, M) = TieudeK
Sh.[J4].Resize(t, M) = KQM
Sh.[J4].Offset(0, M).Resize(t, M) = KQK

Arr = Sh.Range("J4", "J4").Resize(t, M * 2).Value
ReDim SoLan(1 To 1, 1 To UBound(Arr))

For i = 1 To UBound(Arr, 2)
Set Dic = CreateObject("Scripting.Dictionary")
    For j = 1 To UBound(Arr, 1)
        If Arr(j, i) <> Empty Then
            Key = Arr(j, i)
            If Not Dic.Exists(Key) Then
            k = k + 1: Dic.Add (Key), k
                If SoLan(1, i) = Empty Then SoLan(1, i) = Key Else SoLan(1, i) = SoLan(1, i) & "," & Key
            End If
        End If
    Next j
    Set Dic = Nothing
Next i
Sh.[J2].Resize(1, UBound(Arr)) = SoLan
Application.ScreenUpdating = True
MsgBox "OK!", vbInformation, "THÔNG BÁO"
End Sub

Nên tham khảo các code khác nữa nhé.

Bài đã được tự động gộp: 10/3/22

Tôi thuộc tip người chậm hiểu nên không thể đoán đúng ý của chủ thớt, nhiều khi cứ code mò thôi. Ngay cả cái lỗi code bạn ấy đưa lên
" ...ReDim S(1 To 100)
For i = 4 To Lr
t = t + 1...."
Lỗi dòng nào? có bảng thông báo gì không? Cũng không nên cũng phải đoán đó là gì?
Tôi cũng nhắc bạn đó tham khảo các code khác. và vẫn nói bạn đó nếu sử dụng file tôi làm giúp bạn ấy vào mục đích chơi lô đề, đánh bạc... thì hãy chủ động liên hệ với đội ngũ làm tín dụng đen để được hỗ trợ, trợ giúp vô tư, vô bờ bến

Hihi Bác giận em rùi!. Em cám ơn Bác nhiều lắm. Chúc Bác luôn mạnh khoẻ và hạnh phúc.

Bài đã được tự động gộp: 10/3/22

File bài #63, rút bớt vòng for (Chưa kiểm lại kỹ không biết có lỗi gì không)

Option Explicit

Sub Count_Color_NoColor()
Dim Rng As Range, I&, J&, R&, C&, Cols&, iColor&, NoColor&, colorArr$(), noColorArr$()
'--------------------------- Nhap lieu dau vao
Const MyColor = vbYellow
Const MyNoColor = xlNone
Const iR& = 3 'Dòng phía tren moi bang
Set Rng = Sheets("Sheet1").Range("A4:H26") 'Dong du lieu bat dau >=4
'----------------------------
R = Rng.Rows.Count: C = Rng.Columns.Count
Cols = C - 2 'Cot arr can offset
ReDim colorArr(1 To R + iR, 1 To Cols)
ReDim noColorArr(1 To R + iR, 1 To Cols)
For I = 1 To Cols
    colorArr(1, I) = "Lien tuc co mau lien tiep " & Cols + 1 - I
    noColorArr(1, I) = "Khong co mau lien tiep " & Cols + 1 - I
Next
For I = 1 To R
    iColor = 0: NoColor = 0
    For J = C - 1 To 2 Step -1
        If Rng(I, J).Interior.Color = MyColor Then
            If NoColor = 0 Then iColor = iColor + 1 Else Exit For
        ElseIf Rng(I, J).Interior.Pattern = MyNoColor Then
            If iColor = 0 Then NoColor = NoColor + 1 Else Exit For
        End If
    Next
    If iColor Then
        J = Cols + 1 - iColor
        colorArr(I + iR, J) = Rng(I, C).Text
        colorArr(2, J) = IIf(colorArr(2, J) = "", Rng(I, C).Text, colorArr(2, J) & "," & Rng(I, C).Text)
    Else
        J = Cols + 1 - NoColor
        noColorArr(I + iR, J) = Rng(I, C).Text
        noColorArr(2, J) = IIf(noColorArr(2, J) = "", Rng(I, C).Text, noColorArr(2, J) & "," & Rng(I, C).Text)
    End If
Next
Rng(1, C).Offset(-iR, 2).Resize(R + iR, Cols) = colorArr
Rng(1, C).Offset(-iR, Cols + 3).Resize(R + iR, Cols) = noColorArr
End Sub

Em cám ơn anh nhiều ạ. Chúc Anh luôn mạnh khoẻ

 

[tranhoainam9701]

Dựa vào code của thầy @HieuCD. Mình có chỉnh sửa theo ý muốn của chủ topic. Ai đó có thể chỉ giúp cách tối ưu hoặc giản số lần duyệt với ạ

Sub ABC()
Application.ScreenUpdating = False
Dim a$(), b$(), Rng As Range, sRow&, i&, j&, C&, sCol&, x$(), y$()
Set Rng = Sheet1.Range("A4").CurrentRegion
sRow = Rng.Rows.Count
  sCol = Rng.Columns.Count
  ReDim a(1 To sRow, 1 To sCol - 1)
  ReDim x(1 To sRow, 1 To sCol - 1)
  ReDim b(1 To 2, 1 To sCol - 1)
  ReDim y(1 To 2, 1 To sCol - 1)
  For j = sCol - 1 To 1 Step -1
    b(1, j) = "Lien tuc co mau lien tiep " & sCol - j
    y(1, j) = "Khong co mau lien tiep " & sCol - j
  Next
  For i = 1 To sRow
    C = sCol - 1
    For j = sCol - 1 To 1 Step -1
        If Rng(i, sCol - 1).Interior.Color = vbYellow Then
            If Rng(i, j).Interior.Color = vbYellow Then C = C - 1
            If Rng(i, j).Interior.Color <> vbYellow Then
                a(i, C + 1) = Rng(i, sCol)
                If Len(b(2, C + 1)) Then b(2, C + 1) = b(2, C + 1) & "," & a(i, C + 1) Else b(2, C + 1) = a(i, C + 1)
                Exit For
            End If
        Else
            Exit For
        End If
    Next j
  Next i
For i = 1 To sRow
    C = sCol - 1
    For j = sCol - 1 To 1 Step -1
        If Rng(i, sCol - 1).Interior.Pattern = xlNone Then
        If Rng(i, j).Interior.Pattern = xlNone Then C = C - 1
            If Rng(i, j).Interior.Pattern <> xlNone Then
                x(i, C + 1) = Rng(i, sCol)
                If Len(y(2, C + 1)) Then y(2, C + 1) = y(2, C + 1) & "," & x(i, C + 1) Else y(2, C + 1) = x(i, C + 1)
                Exit For
            End If
        Else
            Exit For
        End If
    Next j
Next i
With Sheet1
  .Range("A2").Offset(, sCol + 2).Resize(100000, sCol * 2).ClearContents
  .Range("A2").Offset(, sCol + 2).Resize(2, sCol - 1).Value = b
  .Range("A4").Offset(, sCol + 2).Resize(sRow, sCol - 1).Value = a
  .Range("A2").Offset(, sCol * 2 + 3).Resize(2, sCol - 1).Value = y
  .Range("A4").Offset(, sCol * 2 + 3).Resize(sRow, sCol - 1).Value = x
End With
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

Cám ơn em... nếu nó chạy nhanh chút nữa thì đẹp