So sánh các khoảng giá trị theo hàng (1 người xem)

[switch93]

Em nhờ các bác viết code cho bài toán sau:

B1: các bác lấy tất cả 2 ô kế tiếp nhau có giá trị là A trong 1 hàng (của mã hàng)làm mốc nhập rồi so sánh mốc hay chính so sánh các đoạn [AA:AA] với nhau
B2: sau khi có được giá tri so sánh có [AA:AA] Max rồi tô màu đoạn đó và khoảng ô trống ngay sau đó gần nhất.
B3: Tìm mốc cuối cùng có 2 ô liên tiếp có giá trị A
Lưu ý : Trong bài toán này các bác có thể hiểu A có thể là chữ có thể là số thay đổi tùy ý.

em có gửi file đính kèm mong các xem và giúp đỡ.
Bác doveandrose, BaTe, let's gâu gâu.. Qua giúp em.
Cảm ơn GPE, cảm ơn các bác !

 

[doveandrose]

Vậy tiếp đi cho đẹp...., nhờ mod xóa bài này

sao lại xóa , phải giữ lại các bình luận hầu mọi người có dịp làm quen với vị anh hùng như bạn chứ

 

[ppc0312]

sao lại xóa , phải giữ lại các bình luận hầu mọi người có dịp làm quen với vị anh hùng như bạn chứ

Anh hùng chi mấy cái nhỏ này, chuyện nhỏ đi, nhờ xóa để khỏi nói spam ,
nhờ smod xóa nốt bài này.

 

[switch93]

đưa file đây tôi kiểm mới biết được chứ

Xin gửi file bác doveandrose coi

 

[doveandrose]

Xin gửi file bác doveandrose coi

sửa lại 1 chút

Public Function maxXY(ByVal sourceRG As Range, ByVal fromStr As String, ByVal toStr As String, _
Optional ByVal countType As Byte = 1, Optional ByVal countDist As Long = -1) As Long
Dim hisT, arr As Variant, matHead As Boolean, tempCount As Long, sTmp As String
Dim c As Long, maxCount As Long, afterMax As Long, isAfter As Boolean, uc As Long
Dim i As Byte, ubHist As Long


ReDim hisT(1 To WorksheetFunction.Max(Len(fromStr) + 2, Len(toStr) + 2))
ubHist = UBound(hisT)
sTmp = ";"
For c = 1 To Len(fromStr) Step 1
    sTmp = sTmp & ";" & Mid(fromStr, c, 1)
Next
fromStr = sTmp
sTmp = ";"
For c = 1 To Len(toStr) Step 1
    sTmp = sTmp & ";" & Mid(toStr, c, 1)
Next
toStr = sTmp


arr = sourceRG.Value
ReDim Preserve arr(1 To 1, 1 To UBound(arr, 2) + 1)
uc = UBound(arr, 2)
For c = 1 To uc Step 1
    If arr(1, c) = "" Then
        sTmp = Join(hisT, ";")
        If Right(sTmp, Len(fromStr)) = fromStr Then
            matHead = True
        Else
            If Right(sTmp, Len(toStr)) = toStr And matHead Then
                 If maxCount < tempCount Or countType = 3 Then
                    maxCount = tempCount
                    If countType <> 3 Or countDist = tempCount Then isAfter = True
                    If countType <> 3 Then afterMax = 0
                 End If
                 
            End If
            If Not hisT(ubHist) = "" Then matHead = False
        End If
        If Not hisT(ubHist) = "" Then tempCount = 0
        If c = uc And isAfter And (countType <> 3 Or afterMax < tempCount) Then afterMax = tempCount
        tempCount = tempCount + 1
    Else
        If isAfter Then
            If countType <> 3 Or afterMax < tempCount Then afterMax = tempCount
            isAfter = False
        End If
    End If
    For i = 1 To ubHist - 1 Step 1
        hisT(i) = hisT(i + 1)
    Next
    hisT(ubHist) = arr(1, c)
Next
maxXY = IIf(countType = 1, maxCount, afterMax)
End Function

 

[switch93]

Các bài toán đã có lời giải, chỉ còn yêu cầu cuối là tìm khoảng trống cuối cùng chưa có.
Bác xem giúp em. file em gửi kèm đây.
Đây là bài toán cuối cùng này.
Xin chân thành cảm ơn bác sự giúp đỡ Tận tình, cảm ơn GPE!

 

[doveandrose]

Các bài toán đã có lời giải, chỉ còn yêu cầu cuối là tìm khoảng trống cuối cùng chưa có.
Bác xem giúp em. file em gửi kèm đây.
Đây là bài toán cuối cùng này.
Xin chân thành cảm ơn bác sự giúp đỡ Tận tình, cảm ơn GPE!

Public Function KTC(ByVal sourceRG As Range, ByVal tex As String)
Dim arr, c As Long, i As Byte, tempCount As Long
arr = sourceRG.Value
For c = UBound(arr, 2) To 1 + Len(tex) Step -1
    If arr(1, c) <> "" Then
        For i = 1 To Len(tex) Step 1
            arr(1, c) = arr(1, c - i) & arr(1, c)
        Next
        If arr(1, c) = tex Then KTC = tempCount Else KTC = ""
        Exit Function
    Else
        tempCount = tempCount + 1
    End If
Next
End Function

 

[switch93]

Tất cả đều ổn.em kiểm nghiệm tiếp.
Xin cảm ơn Thầy doveandrose chân thành.
Cảm ơn GPE!

 

[switch93]

Public Function KTC(ByVal sourceRG As Range, ByVal tex As String)
Dim arr, c As Long, i As Byte, tempCount As Long
arr = sourceRG.Value
For c = UBound(arr, 2) To 1 + Len(tex) Step -1
    If arr(1, c) <> "" Then
        For i = 1 To Len(tex) Step 1
            arr(1, c) = arr(1, c - i) & arr(1, c)
        Next
        If arr(1, c) = tex Then KTC = tempCount Else KTC = ""
        Exit Function
    Else
        tempCount = tempCount + 1
    End If
Next
End Function

em đã chạy thử vào kết quả trường hợp XY và XYZ tính ô trống cuối cùng vẫn không ổn.
3 ô XYZ hay 2 ô XY phải kế tiếp nhau theo như file. nhưng chạy code ô X và ô Y có khoảng trắng ở giữa vẫn tính. bác coi lại giúp e.
file đây

 

[doveandrose]

em đã chạy thử vào kết quả trường hợp XY và XYZ tính ô trống cuối cùng vẫn không ổn.
3 ô XYZ hay 2 ô XY phải kế tiếp nhau theo như file. nhưng chạy code ô X và ô Y có khoảng trắng ở giữa vẫn tính. bác coi lại giúp e.
file đây

đúng là code đó chạy sai , sửa lại theo cái này rồi báo lại

Public Function KTC(ByVal sourceRG As Range, ByVal tex As String)
Dim arr, c As Long, i As Byte, tempCount As Long, sTmp As String
arr = sourceRG.Value
sTmp = ";"
For c = 1 To Len(tex) Step 1
    sTmp = sTmp & ";" & Mid(tex, c, 1)
Next
For c = UBound(arr, 2) To 1 + Len(tex) Step -1
    If arr(1, c) <> "" Then
        For i = 1 To Len(tex) Step 1
            arr(1, c) = arr(1, c - i) & ";" & arr(1, c)
        Next
        arr(1, c) = ";" & arr(1, c)
        If arr(1, c) = sTmp Then KTC = tempCount Else KTC = ""
        Exit Function
    Else
        tempCount = tempCount + 1
    End If
Next
End Function