tìm mốc đoạn dài nhất

[zxxzzxxz]

em có file kèm,muốn nhờ anh chị giúp em tìm mốc của đoạn màu đỏ dài nhất. Ví dụ ,ở cột H ,đoạn đỏ dài nhất bắt đầu từ dòng 6 tới dòng 15; ở cột I nó bắt đầu từ dòng 24 tới dòng 36; ở cột J nó từ dòng 4 tới dòng 17.
Em muốn nhờ anh chị giúp em tìm mốc bắt đầu và kết thúc của đoạn dài nhất trong cột bất kì mình muốn ạ.

 

[Nhattanktnn]

em có file kèm,muốn nhờ anh chị giúp em tìm mốc của đoạn màu đỏ dài nhất. Ví dụ ,ở cột H ,đoạn đỏ dài nhất bắt đầu từ dòng 6 tới dòng 15; ở cột I nó bắt đầu từ dòng 24 tới dòng 36; ở cột J nó từ dòng 4 tới dòng 17.
Em muốn nhờ anh chị giúp em tìm mốc bắt đầu và kết thúc của đoạn dài nhất trong cột bất kì mình muốn ạ.

Bạn phải rõ ràng là muốn trả về cái gì? địa chỉ vùng hay số dòng đầu dòng cuối. Rồi kết quả trả về sẽ nằm ở đâu, như thế nào?

 

[zxxzzxxz]

Bạn phải rõ ràng là muốn trả về cái gì? địa chỉ vùng hay số dòng đầu dòng cuối. Rồi kết quả trả về sẽ nằm ở đâu, như thế nào?

cảm ơn bác đã rep. Như hình em muốn tìm mốc dòng bắt đầu và mốc dòng kết thúc của đoạn ,rồi ghi giá trị mốc lên hai dòng trên của cột đó ạ.

 

[Nhattanktnn]

View attachment 263836


cảm ơn bác đã rep. Như hình em muốn tìm mốc dòng bắt đầu và mốc dòng kết thúc của đoạn ,rồi ghi giá trị mốc lên hai dòng trên của cột đó ạ.

Bạn thử code này nha:

Option Explicit
Sub TimDoanDaiNhat()
Dim Rng As Range, ViTri(), iR&, iC&, Rws&, Cols&
Dim MyColor&, subRng As Range, Tmp, i&, iMax&
'************************************************
MyColor = vbRed
Set Rng = Sheets("Sheet1").Range("H3:K38")
Rws = Rng.Rows.Count: Cols = Rng.Columns.Count
ReDim ViTri(1 To 2, 1 To Cols)
'************************************************
For iC = 1 To Cols
    Set subRng = Nothing
    For iR = 1 To Rws
        If Rng(iR, iC).Interior.Color = MyColor Then
            If subRng Is Nothing Then
                Set subRng = Rng(iR, iC)
            Else
                Set subRng = Union(subRng, Rng(iR, iC))
            End If
        End If
    Next
    If Not subRng Is Nothing Then
        Tmp = Split(subRng.Address, ",")
        For i = 0 To UBound(Tmp)
            If Range(Tmp(i)).Rows.Count > iMax Then
                iMax = Range(Tmp(i)).Rows.Count
                ViTri(1, iC) = Range(Tmp(i)).Row
                ViTri(2, iC) = ViTri(1, iC) + iMax - 1
            End If
        Next
    End If
Next
Sheets("Sheet1").Range("H1").Resize(UBound(ViTri), Cols) = ViTri
End Sub

 

[zxxzzxxz]

Bạn thử code này nha:

Option Explicit
Sub TimDoanDaiNhat()
Dim Rng As Range, ViTri(), iR&, iC&, Rws&, Cols&
Dim MyColor&, subRng As Range, Tmp, i&, iMax&
'************************************************
MyColor = vbRed
Set Rng = Sheets("Sheet1").Range("H3:K38")
Rws = Rng.Rows.Count: Cols = Rng.Columns.Count
ReDim ViTri(1 To 2, 1 To Cols)
'************************************************
For iC = 1 To Cols
    Set subRng = Nothing
    For iR = 1 To Rws
        If Rng(iR, iC).Interior.Color = MyColor Then
            If subRng Is Nothing Then
                Set subRng = Rng(iR, iC)
            Else
                Set subRng = Union(subRng, Rng(iR, iC))
            End If
        End If
    Next
    If Not subRng Is Nothing Then
        Tmp = Split(subRng.Address, ",")
        For i = 0 To UBound(Tmp)
            If Range(Tmp(i)).Rows.Count > iMax Then
                iMax = Range(Tmp(i)).Rows.Count
                ViTri(1, iC) = Range(Tmp(i)).Row
                ViTri(2, iC) = ViTri(1, iC) + iMax - 1
            End If
        Next
    End If
Next
Sheets("Sheet1").Range("H1").Resize(UBound(ViTri), Cols) = ViTri
End Sub

rất cảm ơn anh, đã đúng như em muốn ạ. Chúc anh và gia đình sức khỏe ! Cảm ơn diễn đàn !