Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sh As Worksheet, Sh0 As Worksheet, Cls As Range, Rng As Range, sRng As Range
If Not Intersect(Target, [g1]) Is Nothing Then
Dim MyAdd As String, Th As Byte
Dim DMc As Double, GHD As Double, GHT As Double
If [i1].Value = "T" Then Th = 1
Set Sh0 = Sheets("GPE"): [b5].CurrentRegion.Offset(1, 1).ClearContents
For Each Cls In Sh0.Range(Sh0.[D4], Sh0.[d65500].End(xlUp))
For Each Sh In ThisWorkbook.Worksheets
If Left(Sh.Name, 2) = "DL" Then
DMc = Cls.Offset(, 2 * CByte(Right(Sh.Name, 2)) + Th).Value
GHD = DMc * Choose(Target.Value, 0, 0.5, 0.6, 0.7, 0.8, 0.9, 1)
GHT = DMc * Choose(Target.Value, 0.5, 0.6, 0.7, 0.8, 0.9, 1, 9)
Set Rng = Sh.Range(Sh.[c2], Sh.[c65500].End(xlUp))
Set sRng = Rng.Find(Cls.Value, , xlValues, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
DMc = sRng.Offset(, 2 + Th).Value
If DMc > 0 And sRng.Offset(, 1).Value <> "" Then
If GHD <= DMc And DMc < GHT Then
sRng.Interior.ColorIndex = 43
With [B9999].End(xlUp).Offset(1)
.Value = sRng.Offset(, -2).Value
.Offset(, 1).Resize(, 2).Value = Cls.Offset(, -1).Resize(, 2).Value
1 .Offset(, 3).Value = " C" & Right(sRng.Offset(, 1).Value, 1)
2 .Offset(, 4).Value = DMc
End With
End If
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
Next Sh
Next Cls
End If
End Sub
.
