Option Explicit
[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Not Intersect(Target, [c3]) Is Nothing Then
Dim Sh As Worksheet, Rng As Range, sRng As Range
Dim MyAdd As String, GPE As String
Dim eRw As Long, Dg As Long, Thu As Byte, Tiet As Byte, Sang As Byte, Ch As Byte
Set Sh = ThisWorkbook.Worksheets("3-1")
[c7].Resize(10, 7).ClearContents
eRw = Sh.[B65500].End(xlUp).Row
Set Rng = Sh.[c4].Resize(eRw, 36)
Rng.Interior.ColorIndex = 0
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
Dg = sRng.Row: If sRng.Column > 20 Then Sang = 5
Ch = Switch(Dg < 9, 3, Dg < 15, 9, Dg < 21, 15, Dg < 27, 21, Dg < 33, 27, Dg < 39, 33)
Tiet = Dg - Ch
Thu = Choose(Ch \ 3, 1, , 2, , 3, , 4, , 5, , 6) '*'
Dg = sRng.Column
GPE = "'1" & Switch(Dg < 13, "2", Dg < 25, "1", Dg > 25, "0") & "-"
[b6].Offset(Tiet + Sang, Thu).Value = GPE & Sh.Cells(3, Dg).Value
sRng.Interior.ColorIndex = 34 + Range("DSGV").Find(Target.Value).Row Mod 8
Set sRng = Rng.FindNext(sRng): Sang = 0 '<=|'
Loop While Not sRng Is Nothing And MyAdd <> sRng.Address
Else
MsgBox "?"
End If
End If
[B]End Sub[/B]
Option Explicit
[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Not Intersect(Target, [c3]) Is Nothing Then
Dim Sh As Worksheet, Rng As Range, sRng As Range
Dim MyAdd As String, GPE As String
Dim eRw As Long, Dg As Long, Thu As Byte, Tiet As Byte, Sang As Byte, Ch As Byte
Set Sh = ThisWorkbook.Worksheets("3-1")
2 [c7].Resize(10, 7).Clear '[COLOR=blue]***[/COLOR]'
eRw = Sh.[B65500].End(xlUp).Row
Set Rng = Sh.[c4].Resize(eRw, 36)
Rng.Interior.ColorIndex = 0
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
Dg = sRng.Row: If sRng.Column > 20 Then Sang = 5
Ch = Switch(Dg < 9, 3, Dg < 15, 9, Dg < 21, 15, Dg < 27, 21, Dg < 33, 27, Dg < 39, 33)
Tiet = Dg - Ch
Thu = Choose(Ch \ 3, 1, , 2, , 3, , 4, , 5, , 6)
Dg = sRng.Column
GPE = "'1" & Switch(Dg < 13, "2", Dg < 25, "1", Dg > 25, "0") & "-"
9 If [b6].Offset(Tiet + Sang, Thu).Value <> "" Then _
[b6].Offset(Tiet + Sang, Thu).Interior.ColorIndex = 3 '[COLOR=blue]<=|[/COLOR]'
[b6].Offset(Tiet + Sang, Thu).Value = GPE & Sh.Cells(3, Dg).Value
sRng.Interior.ColorIndex = 34 + Range("DSGV").Find(Target.Value).Row Mod 8
Set sRng = Rng.FindNext(sRng): Sang = 0
Loop While Not sRng Is Nothing And MyAdd <> sRng.Address
Else
MsgBox "?"
End If
End If
[B]End Sub[/B]Option Explicit
Sub loc_tkbgv()
Dim Arr(), i As Long, j As Integer, k As Long, dg As Byte
Dim Dic As Object, FirstAddress As String
Dim cell As Range, vung As Range, SRng As Range
Set Dic = CreateObject("Scripting.Dictionary")
Set vung = Union(Range([c4], [r37]), Range([v4], [aj37]))
Application.ScreenUpdating = False
vung.Interior.ColorIndex = 0
Sheet2.UsedRange.Offset(, 3).Clear
i = 3
For Each cell In vung
If Not Dic.exists(cell.Value) And cell.Value <> "" And cell.Value <> "CC" And cell.Value <> "SHL" Then
Dic.Add cell.Value, ""
j = j + 1
Set SRng = vung.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
FirstAddress = SRng.Address
If Not SRng Is Nothing Then
Do
i = SRng.Row
k = SRng.Column
dg = Switch(i < 9, i, i < 14, i + 4, i < 21, i + 8, i < 27, i + 12, i < 33, i + 16, i > 33, i + 20)
If SRng.Column > 21 Then dg = dg + 5
Sheet2.Cells(dg, j + 3) = Sheet1.Cells(3, SRng.Column)
Set SRng = vung.FindNext(SRng)
If i = SRng.Row And k < 19 And SRng.Column < 19 Then Cells(i, k).Interior.ColorIndex = 44: SRng.Interior.ColorIndex = 44: MsgBox SRng & " bi trung"
If i = SRng.Row And k > 21 And SRng.Column > 21 Then Cells(i, k).Interior.ColorIndex = 43: SRng.Interior.ColorIndex = 43: MsgBox SRng & " bi trung"
Loop While FirstAddress <> SRng.Address
End If
End If
Next
Arr = Dic.keys
Sheet2.Activate
[d3].Resize(, Dic.Count) = Arr
[d3].Resize(61, Dic.Count).Sort Key1:=Range("d3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, Orientation:=xlLeftToRight
[d3].Resize(61, Dic.Count).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub
