Вставить группу фигур в столбец и строки с условиями

Question

У меня есть несколько фигур для печати в формате столбцов и строк на основе пользовательского значения ввода. Есть 3 основных входных условия:

1) Нет начальных меток (фигур), которые нужно пропустить 2) Нет меток (фигур) на строку 3) Нет строк на странице

У меня есть один лист данных, в котором есть данные в столбце A (включая фигуры) и количество копий, которые будут напечатаны в столбце B.

Лист данных

Эта тема похожа на Как вставить данные в столбцы и строки таким образом , но здесь есть данные (группа фигур - рисунок) вместо данных

Ожидаемый результат В зависимости от 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

Лист1

Вывод