具有条件的列和行中的“粘贴形状"组 [英] Paste Shapes group in column and rows with conditions

问题描述

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

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

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

数据表

此线程类似于

 选项显式私人子PrintLabels()Dim LabelsToSkip为整数Dim LabelsPerRow为整数昏暗的RowsPerPage作为整数Dim shdata作为工作表昏暗生成为工作表昏暗的shDesignFormat作为工作表暗流只要长Dim curCol只要昏暗的RowsPerPageCount长暗淡如龙昏暗r2昏暗的顶部作为单左昏暗为单身昏暗的整数形状变暗设置shdata = ThisWorkbook.Sheets("Database")设置shgenerate = ThisWorkbook.Sheets("LabelGenerate")设置shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")shgenerate.UsedRange.ClearContentsLabelsToSkip = 1标签每行= 3RowsPerPage = 8当前行= 1curCol = 1RowsPerPageCount = 1'.Top = myShape.Height + 10 '10是垂直间隙黑白标签'.Left = myShape.Left + 10 '10是水平间隙黑白标签左= 0上层= 0对于r = 2到shdata.Range("B"& Rows.Count).End(xlUp).Row我= 1'=========从数据表中复制形状============shdata.Cells(r，"A").复制shDesignFormat.Range("B3")'在打印之前将形状粘贴到设计表(以进行格式化)对于r2 = 1到shdata.Cells(r，"B").Value'=====粘贴生成表格====对于每一个shgenerate.Shape如果shp.Top>然后顶部= shp.顶部+ 10 '10是垂直间隙黑白标签左= shp.左+ 10 '10是水平间隙黑白标签万一下一个设置shp = shDesignFormat.Shapes(矩形"& i)复制生成粘贴有选择.Top =顶部.Left =左结束于下一个r2我=我+ 1下一个Application.CutCopyMode =假结束子 

解决方案

这里是概述方法.

  Sub x()昏暗r作为范围，sh作为形状，shCopy作为形状，i一样长，nCol一样长昏暗nLeft长，nTop长，nRow长，j长，ctr长nCol = 3:nTop = 10:nLeft = 10Application.ScreenUpdating = False对于工作表中的每个sh("Output").sh.Delete下一个sh对于Worksheets("Sheet1").Range("B2"，Worksheets("Sheet1").Range("B"&Rows.Count).End(xlUp))中的每个r对于工作表中的每个sh("Sheet1").如果不相交(sh.TopLeftCell，r.Offset(，-1))什么都没有然后退出下一个sh对于i = 1到r.Value点击率=点击率+ 1复制使用工作表(输出").特殊黏贴设置shCopy = .Shapes(.Shapes.Count)如果ctr Mod nCol = 1，则j = 0nRow = nRow +1万一shCopy.Top =(nTop * nRow)+(shCopy.Height *(nRow-1))shCopy.Left = j *(shCopy.Width + nLeft)j = j + 1结束于接下来我下一个Application.ScreenUpdating =真结束子 

Sheet1

输出

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:

1) No of starting label(shapes) to skip 2) No of label(shapes) per Row 3) No of Rows Per page

I have one datasheet which has data in column A (includes shapes) and No of copies to be printed in column B.

Datasheet

This thread is similar to How to Paste Data in Columns and Rows in this way but here is shapes(Group of shapes - picture) instead of data

Expecting Output As subject to 3 conditions

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

解决方案

Here is an outline approach.

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

Output

这篇关于具有条件的列和行中的“粘贴形状"组的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！