Option Explicit: Option Base 1
Sub Bai01()
On Error Resume Next
Dim lRow As Long, Rw1 As Long, Rw2 As Long, Num1 As Long, Num2 As Long
Dim Rng As Range, RngC As Range, Clls As Range
ReDim mRng(4) As Range: Dim GPE_ As String, StrC As String
Dim SoLan As Byte, Wz As Byte
Sheet1.Select
With Sheet1.Range([A1], [a65432].End(xlUp))
Set Rng = .Find(What:="END/", LookIn:=xlValues)
If Not Rng Is Nothing Then
GPE_ = Rng.Address: Rw1 = Rng.Offset(1).Row
Do
Rw1 = Rng.Offset(1).Row: SoLan = 1 + SoLan
Set Rng = .FindNext(Rng)
Rw2 = Rng.Offset(-1).Row
If Rw1 < Rw2 Then
Select Case SoLan
Case Is < 3
Range(Cells(Rw1, "A"), Cells(Rw2, "N")).Copy _
Destination:=Sheets(Chr(SoLan + 64)).[a2]
Case 3
Set RngC = Range("C" & Rw1 & ":C" & Rw2)
For Each Clls In RngC
For Wz = 1 To 4
StrC = Choose(Wz, "L", "T", "TS", "SX")
If Wz = 3 Then
If Clls = "S" Or Clls = StrC Then
If mRng(3) Is Nothing Then
Set mRng(3) = Clls.Offset(, -2).Resize(, 13)
Else
Set mRng(3) = Union(mRng(3), Clls.Offset(, -2).Resize(, 13))
End If
End If
Else
If Clls = StrC Then
If mRng(Wz) Is Nothing Then
Set mRng(Wz) = Clls.Offset(, -2).Resize(, 13)
Else
Set mRng(Wz) = Union(mRng(Wz), Clls.Offset(, -2).Resize(, 13))
End If
End If
End If
Next Wz
Next Clls
For Wz = 1 To 4
If Not mRng(Wz) Is Nothing Then
mRng(Wz).Copy Destination:=Sheets(Chr(Wz + 66)).[a2]
Set mRng(Wz) = Nothing
End If
Next Wz
Case 4
Range(Cells(Rw1, "C"), Cells(Rw2, "N")).Copy _
Destination:=Sheets(Chr(SoLan + 64)).[O2]
Range(Cells(Rw1, "A"), Cells(Rw2, "B")).Copy _
Destination:=Sheets(Chr(SoLan + 64)).[AB2]
Case 5
Set RngC = Range("C" & Rw1 & ":C" & Rw2)
For Each Clls In RngC
For Wz = 1 To 3
Num1 = Choose(Wz, 0, 40, 80)
Num2 = Choose(Wz, 40, 80, 120)
If Abs(Clls) >= Num1 And Abs(Clls) < Num2 Then
If mRng(Wz) Is Nothing Then
Set mRng(Wz) = Clls.Offset(, -2).Resize(, 13)
Else
Set mRng(Wz) = Union(mRng(Wz), Clls.Offset(, -2).Resize(, 13))
End If
End If
Next Wz
Next Clls
For Wz = 1 To 3
If Not mRng(Wz) Is Nothing Then
mRng(Wz).Copy Destination:=Sheets(Chr(Wz + 70)).[a2]
Set mRng(Wz) = Nothing
End If
Next Wz
Case 6, 7
Range(Cells(Rw1, "A"), Cells(Rw2, "N")).Copy _
Destination:=Sheets(Chr(SoLan + 68)).[a2]
End Select
End If
Rw1 = Rw2 + 2
Loop While Not Rng Is Nothing And Rng.Address <> GPE_
End If
End With
Sheets("D").Select: Set Rng = Nothing
Rw1 = [a65432].End(xlUp).Row: Rw2 = [Ab65500].End(xlUp).Row
ReDim DaCo(Rw2) As Boolean
For Num1 = 2 To Rw1
For Num2 = 2 To Rw2
If Cells(Num1, 1) = Cells(Num2, "AB") And Cells(Num1, 2) = Cells(Num2, "AC") _
And Not DaCo(Num2) Then
DaCo(Num2) = True
If Rng Is Nothing Then
Set Rng = Cells(Num2, "O")
Else
Set Rng = Union(Rng, Cells(Num2, "o"))
End If
End If
Next Num2
Next Num1
For Num2 = 2 To Rw2
If Intersect(Cells(Num2, "O"), Rng) Is Nothing Then _
Cells(Num2, "o").Resize(, 16).Clear
Next Num2
Range([AB2], Cells(Rw2, "AD")).Clear
Sheet1.Select
End Sub
