Question

我试图创建一个宏，它将重命名然后更改多个活动x复选框的链接单元格，然后复制一个新集合并重复该过程。它需要循环约200次。基本上我需要200套具有属性（名称）的复选框，如下所示：

SET 1（活动x复选框）

FL1MON（链接单元格：C5）
FL1TUE（链接单元格：D5）
FL1WED（Link Cell：E5）
FL1THU（Link Cell：F5）
FL1FRI（Link Cell：G5）
FL1SAT（Link Cell：H5）
FL1SUN（Link Cell：I5）

SET 2（活动x复选框）

FL2MON（链接单元格：C25）
FL2TUE（链接单元格：D25）
FL2WED（Link Cell：E25）
FL2THU（链接单元格：F25）
FL2FRI（Link Cell：G25）
FL2SAT（Link Cell：H25）
FL2SUN（链接单元格：I25）

（并重复）......

我在下面附上了一些代码;但是，我相信我最有可能走错方向。另外，我还没弄明白我将如何更改循环中的链接单元格。

Sub CopyDown_Boxes()

Dim oles1 As OLEObject
 Dim oles2 As OLEObject
  Dim oles3 As OLEObject
   Dim oles4 As OLEObject
    Dim oles5 As OLEObject
     Dim oles6 As OLEObject
      Dim oles7 As OLEObject

i = (x * 15) + 5

For x = 1 To 7


Set oles1 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox1")
Set oles2 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox2")
Set oles3 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox3")
Set oles4 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox4")
Set oles5 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox5")
Set oles6 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox6")
Set oles7 = ThisWorkbook.Worksheets("Flight Schedule").OLEObjects("CheckBox7")

    oles1.Name = "FL" & x & "MON"
    oles2.Name = "FL" & x & "TUE"
    oles3.Name = "FL" & x & "WED"
    oles4.Name = "FL" & x & "THU"
    oles5.Name = "FL" & x & "FRI"
    oles6.Name = "FL" & x & "SAT"
    oles7.Name = "FL" & x & "SUN"

Worksheets("Flight Schedule").Shapes.Range(Array("FL" & x & "MON", "FL" & x & "MON", "FL" & x & "MON", _
    "FL" & x & "MON", "FL" & x & "MON", "FL" & x & "MON", "FL" & x & "MON")).Select
Selection.Copy
Range("B" & i).Select
ActiveSheet.Paste

Next x

End Sub

Answer 1

稍微不同的方法可能会给你一个选择。我使用了与单元格的对齐作为定位复选框的基础，并将这些集合垂直放置以与“链接的单元格”对齐。行。此示例只是将它们生成到活动工作表。

checkbox sets

Sub multiCheck()
Dim chkRow As Long, chkCol As Long, LastRow As Long, x As Long
Dim chkLeft As Double, chkTop As Double, chkHeight As Double
Dim chkWidth As Double, numOfSets As Double, linkCellSpace As Double
Dim linkCellRow As Double, linkCellColStart As Double, setSpacing As Integer
Dim chkSet As Integer, chkSpace As Integer
Dim wkArr() As Variant

'initial values
chkRow = 3
chkCol = 2
chkSpace = 2
setSpacing = 6
LastRow = 20
linkCellRow = 5
linkCellSpace = 20
linkCellColStart = 2
'no of week sets
numOfSets = 3

wkArr() = Array("MON", "TUE", "WED", "THU", "FRI", "SAT", "SUN")

    'for each week set
    For chkSet = 0 To numOfSets - 1
            'for each day of week
            For x = 1 To 7
                chkRow = chkRow + chkSpace
                chkLeft = Cells(chkRow, chkCol).Left
                chkTop = Cells(chkRow, chkCol).Top
                chkHeight = Cells(chkRow, chkCol).Height
                chkWidth = Cells(chkRow, chkCol).Width

                ActiveSheet.CheckBoxes.Add(chkLeft, chkTop, chkWidth, chkHeight).Select
                    With Selection
                        .Name = "FL" & chkSet + 1 & wkArr(x - 1)
                        .Caption = .Name
                        .Display3DShading = True
                        .LinkedCell = Cells(linkCellRow + (linkCellSpace * chkSet), linkCellColStart + x).Address
                    End With
            Next x
        chkRow = chkRow + setSpacing
    Next chkSet
End Sub

编辑使用CELLS调整/移动的ACTIVE-X CHECKBOXES

要求的修正案。将flightSheet设置为相应的工作表。默认情况下，代码会将复选框设置为FALSE。

enter image description here

Option Explicit

Sub multiCheckActiveX()
Dim chkBox As New OLEObject
Dim flightSheet As Worksheet
Dim chkRow As Long, chkCol As Long, LastRow As Long, x As Long
Dim chkLeft As Double, chkTop As Double, chkHeight As Double
Dim chkWidth As Double, numOfSets As Double, linkCellSpace As Double
Dim linkCellRow As Double, linkCellColStart As Double, setSpacing As Integer
Dim chkSet As Integer, chkSpace As Integer
Dim wkArr() As Variant

'initial values
chkRow = 3
chkCol = 2
chkSpace = 2
setSpacing = 6
LastRow = 20
linkCellRow = 5
linkCellSpace = 20
linkCellColStart = 2
'no of week sets
numOfSets = 3

Set flightSheet = Sheets("Sheet2")

wkArr() = Array("MON", "TUE", "WED", "THU", "FRI", "SAT", "SUN")

With flightSheet
    'for each week set
    For chkSet = 0 To numOfSets - 1
            'for each day of week
            For x = 1 To 7
                chkRow = chkRow + chkSpace
                chkLeft = .Cells(chkRow, chkCol).Left
                chkTop = .Cells(chkRow, chkCol).Top
                chkHeight = .Cells(chkRow, chkCol).Height
                chkWidth = .Cells(chkRow, chkCol).Width

                Set chkBox = .OLEObjects.Add(ClassType:="Forms.CheckBox.1")
                    With chkBox
                        .Left = chkLeft
                        .Top = chkTop
                        .Width = chkWidth
                        .Height = chkHeight
                        .Name = "FL" & chkSet + 1 & wkArr(x - 1)
                        .Object.Caption = .Name
                        .Object.SpecialEffect = 2
                        .LinkedCell = flightSheet.Cells(linkCellRow + (linkCellSpace * chkSet), linkCellColStart + x).Address
                        .Object.Value = False
                        .Placement = xlMoveAndSize
                    End With
            Next x
        chkRow = chkRow + setSpacing
    Next chkSet
    End With
End Sub

循环ActiveX复选框，重命名并更改链接的单元格，然后复制并重复

1 个答案: