具有条件的列和行中的“粘贴形状”组

Question

我有一些形状可以根据用户定义的输入值以列和行格式打印。基于3种主要输入的条件：

1）要跳过的起始标签（形状）个数 2）每行没有标签（形状） 3）每页行数

我有一个数据表，该数据表的A列中有数据（包括形状），而B列中没有要打印的副本数。

数据表

该线程类似于How to Paste Data in Columns and Rows in this way，但是这里是shapes（一组图形-图片）而不是数据

期望输出符合3个条件

Option Explicit

Private Sub PrintLabels()
   Dim LabelsToSkip As Integer
   Dim LabelsPerRow As Integer
   Dim RowsPerPage As Integer
   Dim shdata As Worksheet
   Dim shgenerate As Worksheet
   Dim shDesignFormat As Worksheet
   Dim curRow As Long
   Dim curCol As Long
   Dim RowsPerPageCount As Long
   Dim r As Long
   Dim r2 As Long
   Dim Top As Single
   Dim Left As Single
   Dim i As Integer
   Dim shp As Shape


   Set shdata = ThisWorkbook.Sheets("Database")
   Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
   Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")

   shgenerate.UsedRange.ClearContents

LabelsToSkip = 1
LabelsPerRow = 3
RowsPerPage = 8

   curRow = 1
   curCol = 1
   RowsPerPageCount = 1

   '.Top = myShape.Height + 10 '10 is the Vertical gap b/w label
   '.Left = myShape.Left + 10 '10 is the Horizontal gap b/w label

   Left = 0
   Top = 0


   For r = 2 To shdata.Range("B" & Rows.Count).End(xlUp).Row
   i = 1
      '======== Copy Shape from Data Sheet============
      shdata.Cells(r, "A").Copy shDesignFormat.Range("B3") 'pasting shape to design sheet before print (to format)

      For r2 = 1 To shdata.Cells(r, "B").Value
         '=====Paste to Generate Sheet ====
    For Each shp In shgenerate.Shapes
        If shp.Top > Top Then
            Top = shp.Top + 10 '10 is the Vertical gap b/w label
            Left = shp.Left + 10 '10 is the Horizontal gap b/w label
        End If
    Next

    Set shp = shDesignFormat.Shapes("Rectangle" & i)

    shp.Copy

    shgenerate.Paste

    With Selection
        .Top = Top
        .Left = Left
    End With

      Next r2
      i = i + 1

   Next r

   Application.CutCopyMode = False
End Sub

Answer 1

这是一种概述方法。

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

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

Sheet1

输出