Tính tần suất lớn nhất và nhỏ nhất

[Vũ Tuấn Tùng]

Em chào các anh chị trên diễn đàn.
Nhờ mọi người giúp em đoạn code VBA để tìm những ô tô màu đỏ lớn nhất và ngắn nhất, những ô không tô màu lớn nhất và nhỏ nhất, và ô ở cột cuối đang là tô màu đỏ hay không tô màu đỏ ạ.
Em có làm ví dụ minh họa vài dòng ạ.
Em xin cảm ơn ạ

 

[BuiQuangThuan]

Em chào các anh chị trên diễn đàn.
Nhờ mọi người giúp em đoạn code VBA để tìm những ô tô màu đỏ lớn nhất và ngắn nhất, những ô không tô màu lớn nhất và nhỏ nhất, và ô ở cột cuối đang là tô màu đỏ hay không tô màu đỏ ạ.
Em có làm ví dụ minh họa vài dòng ạ.
Em xin cảm ơn ạ

Đọc xong thấy rối rối à. Nói sao cho dễ hiểu hơn xíu được không?
Min (Sai)
Max (Sai)..... tính bằng cách nào?

 

[VetMini]

Đọc xong thấy rối rối à. Nói sao cho dễ hiểu hơn xíu được không?
Min (Sai)
Max (Sai)..... tính bằng cách nào?

Tính sai 5 từ tính sai ra 10 được hôn?

 

[Nhattanktnn]

Đọc xong thấy rối rối à. Nói sao cho dễ hiểu hơn xíu được không?
Min (Sai)
Max (Sai)..... tính bằng cách nào?

Đỏ là sai, trắng là đúng. Min(sai) là đỏ liên tiếp nhỏ nhất, Max(sai) là đỏ liên tiếp lớn nhất
Sửa: Mà hình như chưa đúng lắm, vì có số 0

 

[BuiQuangThuan]

Thấy kết quả nó sai sai thế nào ấy nhỉ. Hay mình đang nghĩ sai?

 

[Vũ Tuấn Tùng]

Đỏ là sai, trắng là đúng. Min(sai) là đỏ liên tiếp nhỏ nhất, Max(sai) là đỏ liên tiếp lớn nhất
Sửa: Mà hình như chưa đúng lắm, vì có số 0

Đúng rồi ạ. Min(Đúng) là ô trắng liên tiếp nhỏ nhất,Max(Đúng) là ô trắng liên tiếp lớn nhất. Và Đang(Đúng), đang(Sai) là đoạn liên tục cuối cùng là đúng hay sai ạ

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

View attachment 274400
Thấy kết quả nó sai sai thế nào ấy nhỉ. Hay mình đang nghĩ sai?

Vì chỉ là 1 đoạn chỉ có đúng và không có sai nên là min(Đúng) và max(Đúng) là nhưng nhau ạ

 

[bebo021999]

Dùng tạm củ chuối này, trong khi chờ các sư phụ khác:

Option Explicit
Sub test()
Dim lr&, i&, color&, countD&, countT&, maxD&, maxT&, minD&, minT&, cell As Range, arr
lr = Cells(Rows.Count, "I").End(xlUp).Row
ReDim arr(1 To lr - 2, 1 To 6)
    For i = 3 To lr
        countD = 0: minD = 24: maxD = 0: countT = 0: minT = 24: maxT = 0
        For Each cell In Range(Cells(i, "I"), Cells(i, "AF"))
            color = cell.Interior.ColorIndex
            Select Case color
                Case Is = 3
                    countT = 0
                    countD = countD + 1
                    If countD > maxD Then maxD = countD
                    If countD < minD Then minD = countD
                Case Else
                    countD = 0
                    countT = countT + 1
                    If countT > maxT Then maxT = countT
                    If countT < minT Then minT = countT
            End Select
        Next
        arr(i - 2, 1) = minD: arr(i - 2, 2) = maxD: arr(i - 2, 3) = minT: arr(i - 2, 4) = maxT: arr(i - 2, 5) = countD: arr(i - 2, 6) = countT
        If countT = 24 Then
            arr(i - 2, 1) = 0: arr(i - 2, 2) = 0: arr(i - 2, 3) = 24
        ElseIf countD = 24 Then
                arr(i - 2, 1) = 24: arr(i - 2, 3) = 0: arr(i - 2, 4) = 0
        End If
    Next
Range("B3").Resize(lr - 2, 6).Value = arr
End Sub

 

[HieuCD]

Em chào các anh chị trên diễn đàn.
Nhờ mọi người giúp em đoạn code VBA để tìm những ô tô màu đỏ lớn nhất và ngắn nhất, những ô không tô màu lớn nhất và nhỏ nhất, và ô ở cột cuối đang là tô màu đỏ hay không tô màu đỏ ạ.
Em có làm ví dụ minh họa vài dòng ạ.
Em xin cảm ơn ạ

Chạy sub XYZ . .

Sub XYZ()
  Dim rng As Range, res&()
  Dim sRow&, sCol&, i&, j&, c&, k&, color&
  Set rng = Range("I3:AF" & Range("I" & Rows.Count).End(xlUp).Row)
  sRow = rng.Rows.Count
  sCol = rng.Columns.Count
  ReDim res(1 To sRow, 1 To 7)
  For i = 1 To sRow
    res(i, 1) = i
    k = 1
    color = rng(i, 1).Interior.ColorIndex
    For j = 2 To sCol
      If rng(i, j).Interior.ColorIndex = color Then
        k = k + 1
      Else
        Call AddRes(res, i, k, color, c)
        k = 1
        color = rng(i, j).Interior.ColorIndex
      End If
    Next j
    Call AddRes(res, i, k, color, c)
    If color = 3 Then res(i, 6) = k Else res(i, 7) = k
  Next i
  Range("A3").Resize(sRow, 7) = res
End Sub

Private Sub AddRes(res, i, k, color, c)
  If color = 3 Then c = 2 Else c = 4
  If res(i, c + 1) < k Then res(i, c + 1) = k
  If res(i, c) = Empty Or res(i, c) > k Then
    res(i, c) = k
  End If
End Sub

 

[Maika8008]

Củ chuối gọi củ mài trả lời.

 

[Vũ Tuấn Tùng]

Dùng tạm củ chuối này, trong khi chờ các sư phụ khác:

Option Explicit
Sub test()
Dim lr&, i&, color&, countD&, countT&, maxD&, maxT&, minD&, minT&, cell As Range, arr
lr = Cells(Rows.Count, "I").End(xlUp).Row
ReDim arr(1 To lr - 2, 1 To 6)
    For i = 3 To lr
        countD = 0: minD = 24: maxD = 0: countT = 0: minT = 24: maxT = 0
        For Each cell In Range(Cells(i, "I"), Cells(i, "AF"))
            color = cell.Interior.ColorIndex
            Select Case color
                Case Is = 3
                    countT = 0
                    countD = countD + 1
                    If countD > maxD Then maxD = countD
                    If countD < minD Then minD = countD
                Case Else
                    countD = 0
                    countT = countT + 1
                    If countT > maxT Then maxT = countT
                    If countT < minT Then minT = countT
            End Select
        Next
        arr(i - 2, 1) = minD: arr(i - 2, 2) = maxD: arr(i - 2, 3) = minT: arr(i - 2, 4) = maxT: arr(i - 2, 5) = countD: arr(i - 2, 6) = countT
        If countT = 24 Then
            arr(i - 2, 1) = 0: arr(i - 2, 2) = 0: arr(i - 2, 3) = 24
        ElseIf countD = 24 Then
                arr(i - 2, 1) = 24: arr(i - 2, 3) = 0: arr(i - 2, 4) = 0
        End If
    Next
Range("B3").Resize(lr - 2, 6).Value = arr
End Sub

em cảm ơn bác rất nhiều ạ.

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

Chạy sub XYZ . .

Sub XYZ()
  Dim rng As Range, res&()
  Dim sRow&, sCol&, i&, j&, c&, k&, color&
  Set rng = Range("I3:AF" & Range("I" & Rows.Count).End(xlUp).Row)
  sRow = rng.Rows.Count
  sCol = rng.Columns.Count
  ReDim res(1 To sRow, 1 To 7)
  For i = 1 To sRow
    res(i, 1) = i
    k = 1
    color = rng(i, 1).Interior.ColorIndex
    For j = 2 To sCol
      If rng(i, j).Interior.ColorIndex = color Then
        k = k + 1
      Else
        Call AddRes(res, i, k, color, c)
        k = 1
        color = rng(i, j).Interior.ColorIndex
      End If
    Next j
    Call AddRes(res, i, k, color, c)
    If color = 3 Then res(i, 6) = k Else res(i, 7) = k
  Next i
  Range("A3").Resize(sRow, 7) = res
End Sub

Private Sub AddRes(res, i, k, color, c)
  If color = 3 Then c = 2 Else c = 4
  If res(i, c + 1) < k Then res(i, c + 1) = k
  If res(i, c) = Empty Or res(i, c) > k Then
    res(i, c) = k
  End If
End Sub

cảm ơn bác @HieuCD nhiều ạ