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

A

Akanjana

Board Regular
Joined
Mar 22, 2020
Messages
104
Office Version
  1. 2016
Platform
  1. Windows
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

Sheet1.png


Output Sheet

output.PNG


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

VBA Code: 
[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
 
Last edited:
Sort by date Sort by votes
My thought is that each time it starts a new row, it checks the RowPerPage entry.
If a page break is needed, put it in oneShape.BottomRightCell.Offset(1,0).EntireRow.
And adjust the putX variable to oneShape.BottomRightCell.Offset(2,0).Top + vGap

But I need to go to work right now.
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
mikerickson said:
My thought is that each time it starts a new row, it checks the RowPerPage entry.
If a page break is needed, put it in oneShape.BottomRightCell.Offset(1,0).EntireRow.
And adjust the putX variable to oneShape.BottomRightCell.Offset(2,0).Top + vGap

But I need to go to work right now.
Click to expand...
Can you please update code with the third condition with a fixed size. so I can make changes as you said above. I need to insert page break only when the user limits row per page or else any other alternative if not page break. You can reply to me once you get free ?.
 
Upvote 0
I ll
mikerickson said:
My thought is that each time it starts a new row, it checks the RowPerPage entry.
If a page break is needed, put it in oneShape.BottomRightCell.Offset(1,0).EntireRow.
And adjust the putX variable to oneShape.BottomRightCell.Offset(2,0).Top + vGap

But I need to go to work right now.
Click to expand...

ok, I 'll wait. till you come back from work. Thanks
 
Upvote 0
I had some spare time so I put this together.
VBA Code: 
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
    Dim rowCount As Long, currCol As Long
    Dim i As Long, BreakCell As Range
    Dim oneBreak As HPageBreak
    
    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
    
    uiVal = Application.InputBox("How many rows per page?", Type:=7, Default:="no fixed number")
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    RowsPerPage = Val(uiVal)
    
    Rem clear destination sheet
    With destinationPage
        For Each oneShape In .Shapes
            oneShape.Delete
        Next oneShape
        .ResetAllPageBreaks
    End With

    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.PasteSpecial
        Next i
    Next oneShape
    
    Rem position those shapes
    putX = hGap
    putY = vGap
    rowCount = 0
    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.Placement = xlFreeFloating
        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
            rowCount = rowCount + 1
            If rowCount = RowsPerPage Then
                Set BreakCell = destinationPage.Range("A1")
                Do Until putY < BreakCell.Top
                    Set BreakCell = BreakCell.Offset(1, 0)
                Loop
                Set BreakCell = BreakCell.Offset(1, 0)
                destinationPage.HPageBreaks.Add before:=BreakCell
                putY = BreakCell.Offset(0, 0).Top + vGap
                rowCount = 0
            End If
        Else
            putX = putX + maxWidth + hGap
        End If
        Return
End Sub
 
Upvote 0
mikerickson said:
I had some spare time so I put this together.
VBA Code: 
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
    Dim rowCount As Long, currCol As Long
    Dim i As Long, BreakCell As Range
    Dim oneBreak As HPageBreak
  
    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
  
    uiVal = Application.InputBox("How many rows per page?", Type:=7, Default:="no fixed number")
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    RowsPerPage = Val(uiVal)
  
    Rem clear destination sheet
    With destinationPage
        For Each oneShape In .Shapes
            oneShape.Delete
        Next oneShape
        .ResetAllPageBreaks
    End With

    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.PasteSpecial
        Next i
    Next oneShape
  
    Rem position those shapes
    putX = hGap
    putY = vGap
    rowCount = 0
    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.Placement = xlFreeFloating
        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
            rowCount = rowCount + 1
            If rowCount = RowsPerPage Then
                Set BreakCell = destinationPage.Range("A1")
                Do Until putY < BreakCell.Top
                    Set BreakCell = BreakCell.Offset(1, 0)
                Loop
                Set BreakCell = BreakCell.Offset(1, 0)
                destinationPage.HPageBreaks.Add before:=BreakCell
                putY = BreakCell.Offset(0, 0).Top + vGap
                rowCount = 0
            End If
        Else
            putX = putX + maxWidth + hGap
        End If
        Return
End Sub
Click to expand...


Thanks, A lot sir. it's working great now. if you don't take it. I want the last amendment in code. I will ask the user only for horizontal and vertical gap b/w shape with their input. but other settings like left margin and top margin and other margin I ll adjust directly with page margin settings ways.

your present code print shapes in the following way with an equal gap among all sides of the shape.
your result.PNG



I want to print shapes in the following pattern, so other margins can be adjusted from page margin settings(that I 'll do my self as I have code for that) apart from horizontal and vertical gap b/w shapes.

Expected.PNG


want 0 margins on right, left. top, bottom as I ll adjust with page margin settings. Thanks
 

Attachments

  • your result.PNG
    your result.PNG
    54.5 KB · Views: 0
Upvote 0
I think that this will do what you want.
VBA Code: 
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
    Dim rowCount As Long, currCol As Long
    Dim i As Long, BreakCell As Range
    Dim oneBreak As HPageBreak
    
    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
    
    uiVal = Application.InputBox("How many rows per page?", Type:=7, Default:="no fixed number")
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    RowsPerPage = Val(uiVal)
    
    hGap = Application.InputBox("Horizontal Gap:", Type:=1, Default:="10")
    If hGap < 1 Then Exit Sub: Rem cancel pressed
    
    vGap = Application.InputBox("Vertical Gap:", Type:=1, Default:="10")
    If vGap < 1 Then Exit Sub: Rem cancel pressed
    
    Rem clear destination sheet
    With destinationPage
        For Each oneShape In .Shapes
            oneShape.Delete
        Next oneShape
        .ResetAllPageBreaks
    End With

    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.PasteSpecial
        Next i
    Next oneShape
    
    Rem position those shapes
    putX = 0
    putY = 0
    rowCount = 0
    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.Placement = xlFreeFloating
        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 = 0
            putY = putY + maxHeight + vGap
            currCol = 0
            rowCount = rowCount + 1
            If rowCount = RowsPerPage Then
                Set BreakCell = destinationPage.Range("A1")
                Do Until putY < BreakCell.Top
                    Set BreakCell = BreakCell.Offset(1, 0)
                Loop
                Set BreakCell = BreakCell.Offset(1, 0)
                destinationPage.HPageBreaks.Add before:=BreakCell
                putY = BreakCell.Offset(0, 0).Top
                
                rowCount = 0
            End If
        Else
            putX = putX + maxWidth + hGap
        End If
        Return
End Sub
One thing though, the code does not assume that the shapes are all the same size. It loops through the shapes and finds the largest height and the largest width and positions the shapes based on that. I also centers the shape within that maximum rectangle.
 
Upvote 0
mikerickson said:
I think that this will do what you want.
VBA Code: 
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
    Dim rowCount As Long, currCol As Long
    Dim i As Long, BreakCell As Range
    Dim oneBreak As HPageBreak
   
    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
   
    uiVal = Application.InputBox("How many rows per page?", Type:=7, Default:="no fixed number")
    If TypeName(uiVal) = "Boolean" Then Exit Sub: Rem cancel pressed
    RowsPerPage = Val(uiVal)
   
    hGap = Application.InputBox("Horizontal Gap:", Type:=1, Default:="10")
    If hGap < 1 Then Exit Sub: Rem cancel pressed
   
    vGap = Application.InputBox("Vertical Gap:", Type:=1, Default:="10")
    If vGap < 1 Then Exit Sub: Rem cancel pressed
   
    Rem clear destination sheet
    With destinationPage
        For Each oneShape In .Shapes
            oneShape.Delete
        Next oneShape
        .ResetAllPageBreaks
    End With

    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.PasteSpecial
        Next i
    Next oneShape
   
    Rem position those shapes
    putX = 0
    putY = 0
    rowCount = 0
    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.Placement = xlFreeFloating
        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 = 0
            putY = putY + maxHeight + vGap
            currCol = 0
            rowCount = rowCount + 1
            If rowCount = RowsPerPage Then
                Set BreakCell = destinationPage.Range("A1")
                Do Until putY < BreakCell.Top
                    Set BreakCell = BreakCell.Offset(1, 0)
                Loop
                Set BreakCell = BreakCell.Offset(1, 0)
                destinationPage.HPageBreaks.Add before:=BreakCell
                putY = BreakCell.Offset(0, 0).Top
               
                rowCount = 0
            End If
        Else
            putX = putX + maxWidth + hGap
        End If
        Return
End Sub
One thing though, the code does not assume that the shapes are all the same size. It loops through the shapes and finds the largest height and the largest width and positions the shapes based on that. I also centers the shape within that maximum rectangle.
Click to expand...

Thanks a lot, sir. I can't thank you so much. It finally seems to be working as per my expectations. you are so good and supportive. ♥ :)
 
Upvote 0
Akanjana said:
Thanks a lot, sir. I can't thank you so much. It finally seems to be working as per my expectations. you are so good and supportive. ♥ :)
Click to expand...


Hi sir, after observation with the print sheet, I found that there is a small margin on the left side of first column shapes, also the vertical gap & horizontal gap are not equal even after I put the same input 10 for both vertical and horizontal gaps. please check the image. I know that the right-hand side margin and bottom margin are auto-adjusted based on-page size, which are ok.
Ps: the size of all shapes are equal though.

Space.PNG
 
Upvote 0
Is that the only shape in question. Is Shape 1 wider than Shape2, to the point that shape 1 is fully against the edge of the sheet.

The code is written to find the largest width shape, largest height shape and then center each shape in the maximum rectangle defined by those. If a shape is smaller than the others, its left edge will be to the right of those other shapes.

Other than than, I can't replicate your error.
 
Upvote 0
mikerickson said:
Is that the only shape in question. Is Shape 1 wider than Shape2, to the point that shape 1 is fully against the edge of the sheet.

The code is written to find the largest width shape, largest height shape and then center each shape in the maximum rectangle defined by those. If a shape is smaller than the others, its left edge will be to the right of those other shapes.

Other than than, I can't replicate your error.
Click to expand...

Actually all shapes are of equal size (shape1 and shape 2 has equal size). then also the same issue happens. i know if shape size is unequal than gap will very.but in my case I keep all shapes of the same size.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
User verification-VBA code
Replies
2
Views
413
Sunnygreet
S
K
  • Solved
Previously working very complex VBA now stopped
Replies
7
Views
176
Alex Blakenburg
A
V
  • Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
142
VanGirl
V
S
  • Question
How to exclude a portion of the VBA script? In this script, how do I exclude the script for ''last name''?
2 3
Replies
20
Views
995
Sunnygreet
S
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
387
Agnarr
Agnarr

Forum statistics

Threads
1,215,529
Messages
6,125,343
Members
449,219
Latest member
Smiqer

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top