Sub Sochitiet()
Dim She As Worksheet
Dim cll As Range, Data As Range
Dim Tk As String
Dim DtRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DtRow = S2.[F65536].End(xlUp).Row
S2.AutoFilterMode = False
Set Data = S2.Range("A5:F" & DtRow)
For Each cll In S2.Range("D6:E" & DtRow)
If InStr(1, Tk, cll.Value) = 0 Then
Tk = Tk & "," & cll.Value
TaoSheet (cll.Text)
End If
Next
Set cll = Nothing
Set Data = Nothing
S2.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'=============================
Sub TaoSheet(Ma As String)
Dim She As Worksheet
Set She = Sheets.Add
She.Name = Ma
She.Move After:=Sheets(Sheets.Count)
S3.Cells.Copy She.[a1]
She.[a2] = Ma
Set She = Nothing
End Sub
Sub ChepDL()
Dim Ma As String
Dim sh As Worksheet
Dim k, k1 As Long
k1 = 6
Set sh = Sheets(Sheets.Count)
Ma = sh.[a2]
With S2.Range("D6:E" & S2.[F65536].End(xlUp).Row)
Set c = .Find(Ma, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
k = IIf(c.Column = 4, 0, 1)
sh.Cells(k1, 1) = c.Offset(, -3 - k)
sh.Cells(k1, 2) = c.Offset(, -2 - k)
sh.Cells(k1, 3) = c.Offset(, -1 - k)
sh.Cells(k1, 4) = c.Offset(, IIf(c.Column = 4, 1, -1))
sh.Cells(k1, 5) = IIf(c.Column = 4, c.Offset(, 2), 0)
sh.Cells(k1, 6) = IIf(c.Column = 5, c.Offset(, 1), 0)
k1 = k1 + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Set sh = Nothing
End Sub
---Mình không biết giải thích sao cho bạn hiểu, mình viết lại code bạn tham khảo nhé. Mình bỏ dùng Name của Sheet mà dùng CodeName cho ổn định.
PHP:Sub Sochitiet() Dim She As Worksheet Dim cll As Range, Data As Range Dim Tk As String Dim DtRow As Long Application.ScreenUpdating = False Application.DisplayAlerts = False DtRow = S2.[F65536].End(xlUp).Row S2.AutoFilterMode = False Set Data = S2.Range("A5:F" & DtRow) For Each cll In S2.Range("D6:E" & DtRow) If InStr(1, Tk, cll.Value) = 0 Then Tk = Tk & "," & cll.Value TaoSheet (cll.Text) End If Next Set cll = Nothing Set Data = Nothing S2.Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub '============================= Sub TaoSheet(Ma As String) Dim She As Worksheet Set She = Sheets.Add She.Name = Ma She.Move After:=Sheets(Sheets.Count) S3.Cells.Copy She.[a1] She.[a2] = Ma Set She = Nothing End Sub
Ps:-Bạn đừng dùng On Error Resume Next trong khi còn đang kiểm tra code, như vậy có lỗi mà không biết.
Sub Sochitiet()
Dim Tg As Object
Dim She As Worksheet
Dim Cll As Range, Data As Range
Dim Tk As String
Dim DtRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DtRow = S2.[F65536].End(xlUp).Row
S2.AutoFilterMode = False
Set Tg = CreateObject("scripting.dictionary")
Set Data = S2.Range("A5:F" & DtRow)
For Each Cll In S2.Range("D6:E" & DtRow)
If Cll.Text <> "" And Not Tg.exists(Cll.Text) Then
Tg.Add Cll.Text, Nothing
TaoSheet (Cll.Text)
End If
Next
Set Cll = Nothing
Set Data = Nothing
S2.Select
Set Tg = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'----------------------------------------------------------
Sub TaoSheet(Ma As String)
Dim She As Worksheet
Set She = Sheets.Add
She.Name = Ma
She.Move After:=Sheets(Sheets.Count)
S3.Cells.Copy She.[a1]
She.[a2] = Ma
Set She = Nothing
End Sub
Sub Sochitiet()
Dim She As Worksheet
Dim Cll As Range, Data As Range
Dim Tk As String
Dim DtRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DtRow = S2.[F65536].End(xlUp).Row
S2.AutoFilterMode = False
Set Data = S2.Range("A5:F" & DtRow)
For Each Cll In S2.Range("D6:E" & DtRow)
If Test_Sh(Cll.Text) Then
TaoSheet (Cll.Text)
End If
Next
Set Cll = Nothing
Set Data = Nothing
S2.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'-------------------------------------------------
Function Test_Sh(ByVal ten As String) As Boolean
Test_Sh = True
For Each Sh In Sheets
If Sh.Name = ten Then
Test_Sh = False
Exit Function
End If
Next
End Function
'--------------------------------------------------
Sub TaoSheet(Ma As String)
Dim She As Worksheet
Set She = Sheets.Add
She.Name = Ma
She.Move After:=Sheets(Sheets.Count)
S3.Cells.Copy She.[a1]
She.[a2] = Ma
Set She = Nothing
End Sub