返回列表 上一主題 發帖

自動填滿選項按鈕

  1. Sub ex()
  2. ActiveSheet.OLEObjects.Delete
  3. For Each a In Range("A:A").SpecialCells(xlCellTypeConstants)
  4.    For i = 1 To 5
  5.    With a.Offset(, i)
  6.       ActiveSheet.OLEObjects.Add ClassType:="Forms.OptionButton.1", _
  7.          Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height
  8.    End With
  9.    Next
  10. Next
  11. End Sub
複製代碼
回復 1# caichen3
學海無涯_不恥下問

TOP

回復 3# caichen3
  1. Sub ex()
  2. ActiveSheet.OLEObjects.Delete
  3. For Each a In Range("A:A").SpecialCells(xlCellTypeConstants)
  4.    s = 0
  5.    For i = 1 To 5
  6.    With a.Offset(, i)
  7.       Set ob = ActiveSheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
  8.          Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  9.          ob.Object.GroupName = "群組 " & n
  10.    End With
  11.    Next
  12.   n = n + 1
  13. Next
  14. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 7# caichen3


    ctiveSheet.OLEObjects.Delete
就已經將所有控制項刪除
目的在怕重複執行程式,造成控制項重複新增
  1. Sub ex()
  2. Dim ob As OLEObject
  3. For Each ob In ActiveSheet.OLEObjects
  4.    If ob.progID = "Forms.OptionButton.1" Then ob.Delete
  5. Next
  6. For Each a In Range("A:A").SpecialCells(xlCellTypeConstants)
  7.    s = 0
  8.    For i = 1 To 5
  9.    With a.Offset(, i)
  10.       Set ob = ActiveSheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
  11.          Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  12.          ob.Object.GroupName = "群組 " & n
  13.    End With
  14.    Next
  15.   n = n + 1
  16. Next
  17. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 9# caichen3
  1. Sub ex()
  2. Dim ob As OLEObject
  3. For Each ob In ActiveSheet.OLEObjects
  4.    If ob.progID = "Forms.OptionButton.1" Then ob.Delete
  5. Next
  6. n = 0
  7. For Each a In Range("A:A").SpecialCells(xlCellTypeConstants)
  8.    For i = 1 To 5
  9.    mystr = "選項" & n & "-" & i
  10.    With a.Offset(, i)
  11.       Set ob = ActiveSheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
  12.          Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  13.          ob.Object.Caption = mystr
  14.          ob.Object.GroupName = "群組 " & n
  15.    End With
  16.    Next
  17.   n = n + 1
  18. Next
  19. End Sub
複製代碼
學海無涯_不恥下問

TOP

回復 15# caichen3

不知所云,甚麼叫做b是插入的列?
上傳檔案說明插入前後的狀況
學海無涯_不恥下問

TOP

回復 17# caichen3

你的程式碼來看
在b列插入新的一列,與新增控制項有何關係?
再猜一次看看,可能是在下移I1列的位置插入控制項吧
再無法描述清楚你的需求,可能就無能為力了
  1. Sub ex()
  2. Dim ob As OLEObject
  3. For Each ob In ActiveSheet.OLEObjects
  4.    If ob.progID = "Forms.OptionButton.1" Then ob.Delete
  5. Next
  6. For Each a In Range("A:A").SpecialCells(xlCellTypeConstants)
  7. a.Offset([I1]).EntireRow.Insert
  8.    For i = 1 To 5
  9.    mystr = IIf(i = 1, "非常不重要", IIf(i = 2, "不重要", IIf(i = 3, "普通", IIf(i = 4, "重要", "非常重要"))))
  10.    With a.Offset([I1], i)
  11.       Set ob = ActiveSheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
  12.          Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  13.          ob.Object.Caption = mystr
  14.          ob.Object.GroupName = "群組 " & n
  15.    End With
  16.    Next
  17. Next

  18. End Sub
複製代碼
學海無涯_不恥下問

TOP

本帖最後由 Hsieh 於 2012-3-26 14:01 編輯

回復 21# caichen3
  1. Sub Add_Opt()
  2. Dim ob As OLEObject, Rng As Range, A As Range, B As Range
  3. n = 0
  4. For Each ob In ActiveSheet.OLEObjects
  5. Set A = ob.TopLeftCell
  6.     If Rng Is Nothing Then
  7.       Set Rng = ob.TopLeftCell.EntireRow
  8.       n = 1
  9.       ElseIf Intersect(Rng, ob.TopLeftCell) Is Nothing Then
  10.       Set Rng = Union(Rng, ob.TopLeftCell.EntireRow)
  11.       n = n + 1
  12.     End If
  13. Next
  14. For Each A In Range("A:A").SpecialCells(xlCellTypeConstants)
  15. Set B = Nothing
  16. If Not Rng Is Nothing Then Set B = Intersect(A, Rng)
  17. If B Is Nothing Then
  18.    n = n + 1
  19.    mystr = "OB" & n & "-"
  20.    For i = 1 To 5
  21.    cap = mystr & i
  22.    With A.Offset(, i + 1)
  23.       Set ob = ActiveSheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
  24.          Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  25.          ob.Object.Caption = cap
  26.          ob.Object.GroupName = "群組 " & n
  27.    End With
  28.    Next
  29. End If
  30. Next
  31. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 道德是提昇自我的明燈,不該是呵斥別人的鞭子。
返回列表 上一主題