Lỗi không ổn định trong code khi tạo sheet mới

  • Thread starter Thread starter tam8678
  • Ngày gửi Ngày gửi
Liên hệ QC

tam8678

Đời Xá Chi
Tham gia
30/4/09
Bài viết
417
Được thích
301
Nghề nghiệp
Kế toán
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
 

File đính kèm

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.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Mình bổ xung phần chép Data, bạn tham khảo nhé

PHP:
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
 

File đính kèm

Upvote 0
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.
---
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 :-=.
 

File đính kèm

Upvote 0
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
PHP:
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
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Bài này mình dùng hàm kiểm tra tên sheet, bạn tham khảo 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 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
 

File đính kèm

Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom