Question

不知何故，我们拥有的一些电子表格中创建了数十万个复选框。我不确定这是怎么发生的，但我们无法仅在Excel 2003中打开Excel 2010中的工作表。我编写了一些VBA脚本来删除额外的复选框，它适用于大多数文件。但是，有些文件似乎比其他文件有更多的复选框，脚本因内存不足而死机。这是我的剧本：

Sub ProcessFiles()
  Dim Filename, Pathname, LogFileName As String
  Dim wb As Workbook
  Dim fso As Object

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set log = fso.OpenTextFile("Z:\Temp\Fix.log", 8, True, 0)

  PrintLog ("*** Beginning Processing ***")

  Pathname = "Z:\Temp\Temp\"
  Filename = Dir(Pathname & "*.xls")
  Do While Filename <> ""
    PrintLog ("Opening " & Pathname & Filename)
    Set wb = Workbooks.Open(Pathname & Filename)
    DoWork wb
    PrintLog ("Saving file " & Pathname & Filename)
    wb.Close SaveChanges:=True
    Filename = Dir()
  Loop

  log.Close
End Sub

Sub DoWork(wb As Workbook)
  Dim chk As CheckBox
  Dim c As Integer

  With wb
    Worksheets("Vessel & Voyage Information").Activate
    PrintLog ("Getting count of checkboxes")
    c = ActiveSheet.CheckBoxes.Count
    PrintLog (c & " checkboxes found")
    If (c <= 43) Then
      PrintLog ("Correct # of checkboxes.  Skipping...")
    Else
      c = 0
      For Each chk In ActiveSheet.CheckBoxes
        If Not (Application.Intersect(chk.TopLeftCell, Range("D29:D39")) Is Nothing) Then
          chk.Delete
          c = c + 1
        End If
      Next
      PrintLog ("Deleted " & c & " checkboxes.")
    End If
  End With
End Sub

Public Sub PrintLog(argument As String)
    If Not log Is Nothing Then
        log.WriteLine Format(Now(), "yyyy-MM-dd hh:mm:ss") & ": " & argument
    End If
End Sub

脚本在c = ActiveSheet.CheckBoxes.Count的{{1}}处失败，或者，如果我对该行发表评论，则会在DoWork处失败。我猜测调用For Each chk In ActiveSheet.CheckBoxes会收集所有复选框，而且会有太多复选框因此而死。

有没有办法在不使用ActiveSheet.CheckBoxes的情况下逐步浏览工作表上的每个复选框？

Answer 1

我会尝试使用形状集合和迭代器的索引器intead：

Sub DeleteCheckBoxes()
  Dim itms As shapes, i&, count&, deleted&
  Set itms = ActiveSheet.Shapes

  On Error GoTo ErrHandler
  For i = 1& To &HFFFFFFF
    If itms(i).Type = msoFormControl Then
      If itms(i).FormControlType = xlCheckBox Then
        count = count + 1
        If count > 43 Then 
          itms(i).Delete
          deleted = deleted + 1
          i = i - 1
        End If
      End If
    End If
  Next

ErrHandler:
  Debug.Print "Count   " & count
  Debug.Print "Deleted " & deleted
End Sub

Answer 2

从this page起，这是否有效：

Sub Count_CheckBoxes()
Dim cnt     As Long
Dim cbx     As OLEObject

cnt = 0
'Count CheckBoxes
For Each cbx In ActiveSheet.OLEObjects
    If TypeName(cbx.Object) = "CheckBox" Then
        cnt = cnt + 1
    End If
Next

End Sub

使用VBA删除数以千计的复选框

2 个答案: