How to Copy Paste Shape with 3 Conditions (Images and test Code included)

[Akanjana]

Hi, I have some shapes to print in columns and rows format based on the user-defined input Value. there are 3 main inputs based conditions: I have code which do most of the work. but without condition

1) No of starting labels(shapes) to skip (blank space in place of shape)
2) No of the labels(shapes) per Row
3) No of Rows Per page

Sheet1

Output Sheet

Following codes I have tried which generate the above pattern. but before print, I need to ask the user three conditions.

[CODE=vba][CODE=vba]
Sub x()

Dim r As Range, sh As Shape, shCopy As Shape, i As Long, nCol As Long
Dim nLeft As Long, nTop As Long, nRow As Long, j As Long, ctr As Long

  ' Dim LabelsToSkip As Integer
  ' Dim LabelsPerRow As Integer
  ' Dim RowsPerPage As Integer

  'LabelsToSkip = 1 'user defined value
  'LabelsPerRow = 3 'user defined value
  'RowsPerPage = 8 'user defined value
  'horizontal gap b/w shape user defined
  'vertical gap b/w shape  user defined


nCol = 3: nTop = 10: nLeft = 10

Application.ScreenUpdating = False

For Each sh In Worksheets("Output").Shapes
    sh.Delete
Next sh

For Each r In Worksheets("Sheet1").Range("B2", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
    For Each sh In Worksheets("Sheet1").Shapes
        If Not Intersect(sh.TopLeftCell, r.Offset(, -1)) Is Nothing Then Exit For
    Next sh
    For i = 1 To r.Value
        ctr = ctr + 1
        sh.Copy
        With Worksheets("Output")
            .PasteSpecial
            Set shCopy = .Shapes(.Shapes.Count)
            If ctr Mod nCol = 1 Then
                j = 0
                nRow = nRow + 1
            End If
            shCopy.Top = (nTop * nRow) + (shCopy.Height * (nRow - 1))
            shCopy.Left = j * (shCopy.Width + nLeft)
            j = j + 1
        End With
    Next i
Next r

Application.ScreenUpdating = True

End Sub

[/CODE][/CODE]


Respected team, please help
@mikerickson
@Snakehips
@Domenic
@Fluff
@Eric W

 

[Akanjana]

Hello, anyone can you please have a look?

@DanteAmor

 

[Yongle]

You will annoy members by repeatedly mentioning them like this! @Yongle

It is reasonable to expect to wait 24 hours for a response
.
.

I need to ask the user three conditions

    Dim LabelsToSkip As Integer
    Dim LabelsPerRow As Integer
    Dim RowsPerPage As Integer
    LabelsToSkip = Application.InputBox("Labels to skip ?", "Enter a number", 1, , , , , 1)
    LabelsPerRow = Application.InputBox("Labels per row ?", "Enter a number", 3, , , , , 1)
    RowsPerPage = Application.InputBox("Rows per page ?", "Enter a number", 8, , , , , 1)
  
    MsgBox "Labels to skip " & LabelsToSkip & vbCr & "Labels per row " & LabelsPerRow & vbCr & "Rows per page " & RowsPerPage

 

[Akanjana]

You will annoy members by repeatedly mentioning them like this! @Yongle

It is reasonable to expect to wait 24 hours for a response
.
.

    Dim LabelsToSkip As Integer
    Dim LabelsPerRow As Integer
    Dim RowsPerPage As Integer
    LabelsToSkip = Application.InputBox("Labels to skip ?", "Enter a number", 1, , , , , 1)
    LabelsPerRow = Application.InputBox("Labels per row ?", "Enter a number", 3, , , , , 1)
    RowsPerPage = Application.InputBox("Rows per page ?", "Enter a number", 8, , , , , 1)

    MsgBox "Labels to skip " & LabelsToSkip & vbCr & "Labels per row " & LabelsPerRow & vbCr & "Rows per page " & RowsPerPage

Thanks, Yongle for coming forward to support me. I shall take care of your words for not mentioning others for future posts.
regarding your codes posted above, it asks the user about three conditions but my main part is how to generate labels with those conditions. I mean I need to generate labels according to those conditions once after a user enters the value. I need body part codes. and I am stuck with that. Thanks

 

[Yongle]

"Mentioning" is fine - but use it wisely so that it does not appear to be "begging"

 

[Akanjana]

You said right. but I was helpless as no support for long, not about this thread. but finally, you came forward.

 

[mikerickson]

Perhaps this will do what you want, change the sheet variables to meet your need.

Sub test()
    Dim ShapeToSkip As Long
    Dim ShapePerRow As Long
    Dim RowsPerPage As Long
    Dim hGap As Single, vGap As Single
    Dim sourcePage As Worksheet, destinationPage As Worksheet
    Dim uiVal As Variant
    Dim oneShape As Shape
    Dim maxHeight As Single, maxWidth As Single
    Dim putX As Single, putY As Single
    Dim i As Long
    
    hGap = 10: vGap = 10: Rem defaults
    Set sourcePage = Sheet1
    Set destinationPage = Sheet2
    uiVal = Application.InputBox("Which shape to skip", Type:=7)
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    ShapeToSkip = Val(uiVal)
    
    ShapePerRow = Application.InputBox("How many shapes per row", Type:=1, Default:=3)
    If ShapePerRow < 1 Then Exit Sub: Rem cancel pressed
    
    For Each oneShape In destinationPage.Shapes
        oneShape.Delete
    Next oneShape
    'Exit Sub
    
    For Each oneShape In sourcePage.Shapes
        ShapeToSkip = ShapeToSkip - 1
        If ShapeToSkip <> 0 Then
            If maxHeight < oneShape.Height Then maxHeight = oneShape.Height
            If maxWidth < oneShape.Width Then maxWidth = oneShape.Width
            oneShape.Copy
            For i = 1 To oneShape.TopLeftCell.Offset(0, 1).Value
                destinationPage.Paste
            Next i
        End If
    Next oneShape
    
    putX = hGap
    putY = vGap
    i = 0
    For Each oneShape In destinationPage.Shapes
        oneShape.Left = putX
        oneShape.Top = putY
        i = i + 1
        If i = ShapePerRow Then
            putX = hGap
            putY = putY + maxHeight + vGap
            i = 0
        Else
            putX = putX + maxWidth + hGap
        End If
    Next oneShape
    
End Sub

 

[Akanjana]

Hi sir, I just named sheets as you mentioned. but it doesn't seem to be copy-pasting shapes like my above codes. maybe you understood my requirement in a different way to skip part. I am attaching an image for the print pattern independent of cells (want to print shapes in the following manner after considering horizontal and vertical gap and with other 3 conditions in image). please have a look.

 

[mikerickson]

Yes, I had mis-interpreted the meaning of the skip variable.

Sub test()
    Dim InitialBlanks As Long
    Dim ShapePerRow As Long
    Dim RowsPerPage As Long
    Dim hGap As Single, vGap As Single
    Dim sourcePage As Worksheet, destinationPage As Worksheet
    Dim uiVal As Variant
    Dim oneShape As Shape
    Dim maxHeight As Single, maxWidth As Single
    Dim putX As Single, putY As Single, currCol As Long
    Dim i As Long
    
    hGap = 10: vGap = 10: Rem defaults
    Set sourcePage = Sheet1
    Set destinationPage = Sheet2
    
    Rem get user input values
    uiVal = Application.InputBox("Start with how Many blanks?", Type:=1, Default:=0)
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    InitialBlanks = Val(uiVal)
    
    ShapePerRow = Application.InputBox("How many shapes per row", Type:=1, Default:=3)
    If ShapePerRow < 1 Then Exit Sub: Rem cancel pressed
    
    Rem clear destination sheet
    For Each oneShape In destinationPage.Shapes
        oneShape.Delete
    Next oneShape
    
    Rem make all needed shapes
    For Each oneShape In sourcePage.Shapes
        If maxHeight < oneShape.Height Then maxHeight = oneShape.Height
        If maxWidth < oneShape.Width Then maxWidth = oneShape.Width
        oneShape.Copy
        For i = 1 To oneShape.TopLeftCell.Offset(0, 1).Value
            destinationPage.Paste
        Next i
    Next oneShape
    
    Rem position those shapes
    putX = hGap
    putY = vGap
    currCol = 0
    
    Rem initial blank locations
    For i = 1 To InitialBlanks
        GoSub IncrimentLocation
    Next i
    
    Rem position the new shapes
    For Each oneShape In destinationPage.Shapes
        oneShape.Left = putX + (maxWidth - oneShape.Width) / 2
        oneShape.Top = putY + (maxHeight - oneShape.Height) / 2
        GoSub IncrimentLocation
    Next oneShape
    
    Exit Sub
IncrimentLocation:
     currCol = currCol + 1
        If currCol = ShapePerRow Then
            putX = hGap
            putY = putY + maxHeight + vGap
            currCol = 0
        Else
            putX = putX + maxWidth + hGap
        End If
        Return
End Sub

 

[Akanjana]

Yes, I had mis-interpreted the meaning of the skip variable.

Sub test()
    Dim InitialBlanks As Long
    Dim ShapePerRow As Long
    Dim RowsPerPage As Long
    Dim hGap As Single, vGap As Single
    Dim sourcePage As Worksheet, destinationPage As Worksheet
    Dim uiVal As Variant
    Dim oneShape As Shape
    Dim maxHeight As Single, maxWidth As Single
    Dim putX As Single, putY As Single, currCol As Long
    Dim i As Long
   
    hGap = 10: vGap = 10: Rem defaults
    Set sourcePage = Sheet1
    Set destinationPage = Sheet2
   
    Rem get user input values
    uiVal = Application.InputBox("Start with how Many blanks?", Type:=1, Default:=0)
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    InitialBlanks = Val(uiVal)
   
    ShapePerRow = Application.InputBox("How many shapes per row", Type:=1, Default:=3)
    If ShapePerRow < 1 Then Exit Sub: Rem cancel pressed
   
    Rem clear destination sheet
    For Each oneShape In destinationPage.Shapes
        oneShape.Delete
    Next oneShape
   
    Rem make all needed shapes
    For Each oneShape In sourcePage.Shapes
        If maxHeight < oneShape.Height Then maxHeight = oneShape.Height
        If maxWidth < oneShape.Width Then maxWidth = oneShape.Width
        oneShape.Copy
        For i = 1 To oneShape.TopLeftCell.Offset(0, 1).Value
            destinationPage.Paste
        Next i
    Next oneShape
   
    Rem position those shapes
    putX = hGap
    putY = vGap
    currCol = 0
   
    Rem initial blank locations
    For i = 1 To InitialBlanks
        GoSub IncrimentLocation
    Next i
   
    Rem position the new shapes
    For Each oneShape In destinationPage.Shapes
        oneShape.Left = putX + (maxWidth - oneShape.Width) / 2
        oneShape.Top = putY + (maxHeight - oneShape.Height) / 2
        GoSub IncrimentLocation
    Next oneShape
   
    Exit Sub
IncrimentLocation:
     currCol = currCol + 1
        If currCol = ShapePerRow Then
            putX = hGap
            putY = putY + maxHeight + vGap
            currCol = 0
        Else
            putX = putX + maxWidth + hGap
        End If
        Return
End Sub

Thank you, sir, for the awesome code. it works as per my expectations. but you missed 3rd condition ( i.e No. of Rows Per page ). no of shapes Rows Per Page I want to ask the user before print. I am not sure how it will work, maybe it can be based on the horizontal page break or else the next page might be total of all shape size in page + vertical gap b/w shape - total page size = next page (then here start next page row). Can you please check.