Snasui Excel Forum

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

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

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