Excel Forum

Code: Select all

 
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select

Code: Select all

Sub Button1()

Select Case Range("C3")

Case "1"
On Error Resume Next
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
Case "2"
On Error Resume Next
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
 '2
    Sheets("SHAPE").Select
    Range("B3").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
Case "3"
  On Error Resume Next
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
'2
    Sheets("SHAPE").Select
    Range("B3").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
'3
    Sheets("SHAPE").Select
    Range("B4").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B4").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B4").Select
    ActiveSheet.Pictures.Paste.Select
    End Select
End Sub

Code: Select all

Sub Button1()
    Dim l As Long, tg As Range
    Dim i As Integer, k As Integer
    i = 1
    Sheets("pic1").DrawingObjects.Delete
    For l = 1 To Sheets("SHAPE").Range("c3").Value
        Sheets("SHAPE").Range("b1").Offset(i, 0).Copy
        With Sheets("pic1")
            .Activate
            Set tg = .Range("b1").Offset(i, k)
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height '36.5
                .Width = tg.Width '101
            End With
        End With
        Application.CutCopyMode = False
        If i = 12 Then
            i = 1
            k = k + 1
        Else
            i = i + 1
        End If
    Next l
End Sub

Code: Select all

Sub Button1()
    Dim l As Long, tg As Range
    Dim i As Integer, k As Integer
    Dim j As Integer, m As Integer, n As Integer
    i = 0
    j = 0
    Sheets("pic1").DrawingObjects.Delete
    Sheets("pic2").DrawingObjects.Delete
    For l = 1 To Sheets("SHAPE").Range("c3").Value
        Sheets("SHAPE").Range("b1").Offset(l, 0).Copy
    
        With Sheets("pic1")
            .Activate
            Set tg = .Range("b2").Offset(i, 0).MergeArea
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height
                .Width = tg.Width
            End With
            k = k + 1
        End With
       If k Mod 10 = 0 Then
          i = i + 8
       Else
          i = i + 2
       End If
       
       With Sheets("pic2")
            .Activate
            Set tg = .Range("b2").Offset(j, n).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 5 = 0 Then
          n = n + 4
          j = 0
       Else
          j = j + 5
       End If
       Application.CutCopyMode = False
    Next l
End Sub