Lỗi không ổn định trong code khi tạo sheet mới (1 người xem)

[tam8678]

Tôi có xem, học trên GPE các code về trích và tạo sheet mới. Khi vận dụng thì phát sinh lỗi, rất mong các anh em trên GPE xem và hướng dẫn. Mong muốn được nêu rõ trong file đính kèm, nếu không rõ vui lòng thông báo. Rất cám ơn

 

[sealand]

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.

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.

 

[sealand]

Mình bổ xung phần chép Data, bạn tham khảo nhé

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

 

[tam8678]

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.

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.

---
Anh Sealand cho em hỏi: trong trường hợp này khi chuổi sắp xếp không theo thứ tự thì khi trích ra sheet mới có lỗi (trích thiếu sheet). Nếu đúng anh xem lại giúp em cách giải quyết hoặc đi theo hướng khác. Cám ơn anh nhiều, đính kèm file .

 

[sealand]

Không phải do không thứ tự mà do lồng mã nên hàm Intr() không phân biệt được thôi.Tốt nhất dùng Dictionary bảo đảm độ chính xác cao hơn (Hoặc kiểm tra tên sheet) bài này dùng Dictionary

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

 

[sealand]

Bài này mình dùng hàm kiểm tra tên sheet, bạn tham khảo nhé

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