Option Explicit
[B]Sub DemLWA_WP()[/B]
On Error GoTo Loi_
Dim Rng As Range, Clls As Range, sRng As Range, fRng As Range
Dim Dem As Byte, Max_ As Byte, MyColor As Byte, So1 As Byte
Dim Jj As Long, lRow As Long, Timer_ As Double
Application.ScreenUpdating = False
lRow = Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Timer_ = Timer()
For Jj = 6 To lRow
Set fRng = Rows(Jj).Find("W", , xlFormulas, xlPart)
If Not fRng Is Nothing Then
Set Rng = Range(fRng.Offset(, -1), Cells(Jj, 255).End(xlToLeft))
With Application.WorksheetFunction
So1 = .CountIf(Rng, "*" & "W" & "?")
End With
Select Case So1
Case 1
Cells(Jj, 1).Value = 1
Case 2
Cells(Jj, 1).Value = IIf(InStr(fRng.Offset(, 1).Value, "W"), 2, 1)
Case Is > 2
Dem = 0
For Each Clls In Rng
With Clls
If .Value <> "" And InStr(.Value, "W") > 0 Then
Dem = Dem + 1: If Max_ < Dem Then Max_ = Dem
ElseIf .Value = "" Or InStr(.Value, "W") = 0 Then
If Max_ < Dem Then Max_ = Dem
Dem = 0
End If
End With
Next Clls
Cells(Jj, 1).Value = Max_: Max_ = 0
End Select
End If
Next Jj
MyColor = [A5].Interior.ColorIndex + 1: [A2] = Timer() - Timer_
[A5].Interior.ColorIndex = IIf(MyColor > 41, 34, MyColor)
Err_: Exit Sub
Loi_: [A5].Interior.ColorIndex = 35
Resume Err_
[B]End Sub[/B]