vba โค้ด copy pase มี error บางครั้ง

[Vespaclassic]

เขียน vba ให้ copy จากหน้า sheet "BBS" ไปหน้า sheet "tag"

โค้ด ทำงานได้ปกติ บางครั้ง copy สมบูรณ์
แต่บางครั้ง เกิดมี error 104 กลางทาง copy ไปไม่หมด ต้องกด end แล้วกดใหม่
พยายามแก้แล้ว ก็ไม่หาย


ไม่แน่ในเป็นบัคหรือบัคหรือเปล่าครับ

ลองใช้ทั้ง excel 365 excel2019 เปลี่ยนเครื่องคอม ก็เป็นเหมือนกัน คือไม่ได้เป็นทุกครั้ง

Code: Select all

Sub Button_ok()
        Dim l As Long, tg As Range, ttg As Range
        
    Dim i As Integer, k As Integer, tt As Integer
    Dim j As Integer, m As Integer, n As Integer
    i = 0
    j = 0
     
    Sheets("TAG01").DrawingObjects.Delete
    Sheets("True").DrawingObjects.Delete
    
    For l = 1 To Sheets("BBS").Range("i7").Value
        Sheets("BBS").Range("I9").Offset(l, 0).Copy
    
  
     
'----- true
      
      With Sheets("true")
            .Activate
            Set ttg = .Range("k10").Offset(l, 0).MergeArea
            ttg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = ttg.Height
                .Width = ttg.Width
            End With
            tt = tt + 1
        End With
  '----- true
  
  
 '      If k Mod 20 = 0 Then
     '     i = i + 18
    '   Else
      '    i = i + 3
     '  End If
       
       With Sheets("TAG01")
            .Activate
            Set tg = .Range("E8").Offset(n, j).MergeArea
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height
                .Width = tg.Width
            End With
            m = m + 1
        End With
       If m Mod 3 = 0 Then
          n = n + 12
          j = 0
       Else
          j = j + 9
       End If
       Application.CutCopyMode = False
    Next l
    
    '---------
    
   
       
End Sub
  

[snasui]

ลองปรับ Code เป็นด้านล่างครับ

Code: Select all

Sub Button_ok()
    Dim l As Long, tg As Range, ttg As Range
    Dim i As Integer, k As Integer, tt As Integer
    Dim j As Integer, m As Integer, n As Integer
    i = 0
    j = 0
    
    On Error GoTo ResumeAgain:
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Sheets("TAG01").DrawingObjects.Delete
    Sheets("True").DrawingObjects.Delete
    
    For l = 1 To Sheets("BBS").Range("i7").Value
        Sheets("BBS").Range("I9").Offset(l, 0).Copy
     
'----- true
      
      With Sheets("true")
            .Activate
            Set ttg = .Range("k10").Offset(l, 0).MergeArea
            ttg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = ttg.Height
                .Width = ttg.Width
            End With
            tt = tt + 1
        End With
  '----- true

       With Sheets("TAG01")
            .Activate
            Set tg = .Range("E8").Offset(n, j).MergeArea
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height
                .Width = tg.Width
            End With
            m = m + 1
        End With
       If m Mod 3 = 0 Then
          n = n + 12
          j = 0
       Else
          j = j + 9
       End If
       Application.CutCopyMode = False
    Next l
    
    '---------
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Exit Sub

ResumeAgain:
    Resume
       
End Sub

[Vespaclassic]

ขอบคุณครับ

นำไปลองแล้วครับ โปรแกรมค้างเลยครับ เครื่องอื่นก็เป็นครับ

[snasui]

Code ที่ตอบไปในเครื่องผมสามารถทำงานได้ ก็เป็นที่น่าแปลกอยู่เหมือนกันครับ

ลองอีก Code ใช้วิธีหน่วงเวลาเข้าไปช่วย ในเครื่องผมสามารถทำงานได้เช่นกันครับ

Code: Select all

Sub Button_ok()
    Dim l As Long, tg As Range, ttg As Range
    Dim i As Integer, k As Integer, tt As Integer
    Dim j As Integer, m As Integer, n As Integer
    Dim img As Object
    
    i = 0
    j = 0
    
    Application.ScreenUpdating = False
    Sheets("TAG01").DrawingObjects.Delete
    Sheets("True").DrawingObjects.Delete
    
    For l = 1 To Sheets("BBS").Range("i7").Value
        Sheets("BBS").Range("I9").Offset(l, 0).Copy

'----- true
      With Sheets("true")
            .Activate
            Set ttg = .Range("k10").Offset(l, 0).MergeArea
            ttg.Activate
            Application.Wait Now() + TimeSerial(0, 0, 1)
            Set img = .Pictures.Paste.ShapeRange
            With img
                .LockAspectRatio = msoFalse
                .Height = ttg.Height
                .Width = ttg.Width
            End With
            tt = tt + 1
        End With
  '----- true

       With Sheets("TAG01")
            .Activate
            Set tg = .Range("E8").Offset(n, j).MergeArea
            tg.Activate
            Application.Wait Now() + TimeSerial(0, 0, 1)
            Set img = .Pictures.Paste.ShapeRange
            With img
                .LockAspectRatio = msoFalse
                .Height = tg.Height
                .Width = tg.Width
            End With
            m = m + 1
        End With
       If m Mod 3 = 0 Then
          n = n + 12
          j = 0
       Else
          j = j + 9
       End If
       Application.CutCopyMode = False
    Next l
    Application.ScreenUpdating = True
End Sub