Question

我有一个矩阵，尺寸为 300x300（x 和 y，大小因项目而异）。各个行的名称/编号被转置到列中。矩阵是对角划分的，我用它来标记不同“系统”之间的关系。标签必须是唯一的编号。看图：

我不想重复关系，所以我只想使用白色单元格添加标签。（黑色的表示系统不能和自己有关系。）

我试图创建一个范围，我稍后会应用验证，它会显示标记的下一个数字：

Public MatrixRange as Range

Private Sub Worksheet_Activate()
Dim n As Integer
Dim NextRange As Range
Dim OldRange As Range
Dim LastRow As Long

With shMatrix
    LastRow = .Range("A" & .Rows.Count).End(xlUp).row
    Set MatrixRange = .Range("C11")
    If LastRow <= 1 Then Exit Sub 
    
    For n = 2 To .Range(.Range("A9").Offset(1, 0).Address, "A" & LastRow).Rows.Count
        Set OldRange = MatrixRange
        Set NextRange = .Range(.Range("B9").Offset(n, 1), .Range("B9").Offset(n, -1 + n))
        Set MatrixRange = Union(OldRange, NextRange)
        
    Next n
End With

End Sub

这段代码为我提供了我想要的正确范围，但是当我打开工作簿或尝试保存时，它有时会占用大量内存。当我启动它时，RAM 会不断上升，在工作簿崩溃之前没有任何错误消息。重写代码以选择整个矩阵，而不仅仅是矩阵的一半，似乎解决了这个问题。

我的问题是：是否可以使用不同的方法重写代码以便获得正确的范围，或者我的代码中是否存在任何会造成内存泄漏的缺陷？

如果未创建 MatrixRange，我在应用验证时也会调用上述子程序：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim ValMax As Integer

If MatrixRange Is Nothing Then
    Call CreateMatrixRange
End If

ValMax = Application.WorksheetFunction.Max(MatrixRange)

With MatrixRange.Validation

    .Delete
    .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
    Operator:=xlEqual, Formula1:=ValMax + 1
    .IgnoreBlank = True
    .InCellDropdown = False
    .InputTitle = "Next number"
    .ErrorTitle = "Error"
    .InputMessage = ValMax + 1
    .ErrorMessage = "Next number is: " & ValMax + 1
    .ShowInput = True
    .ShowError = True
    
End With
End Sub

感谢您的回答！

Answer 1

尝试以下操作：

Option Explicit

Private prMatrix As Range
'* plLastRow is used to check if the matrix range changes after it had been set
Private plLastRow As Long

Private Function GetMatrixRange() As Range
    Dim lStartCol As Long: lStartCol = 3
    Dim lStartRow As Long: lStartRow = 11
    Dim lLastRow As Long
    Dim i As Long
    
    With shMatrix
        lLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lLastRow < lStartRow Then lLastRow = lStartRow
        
        If prMatrix Is Nothing Or lLastRow <> plLastRow Then
            plLastRow = lLastRow
            Set prMatrix = .Cells(lStartRow, lStartCol)
            
            '* Row Number -> Number of Columns mapping
            '* Row 11 -> 1 column
            '* Row 12 -> 2 columns
            '* Row 13 -> 3 columns , ...etc
            '* Therefore, Number Of Columns = Row Number - lStartRow + 1
            For i = lStartRow + 1 To lLastRow
                Set prMatrix = Union(prMatrix, .Cells(i, lStartCol).Resize(1, i - lStartRow + 1))
            Next i
        End If
    End With
    
    Set GetMatrixRange = prMatrix
End Function

Private Function GetNextValue() As Long
    GetNextValue = WorksheetFunction.Max(GetMatrixRange) + 1
End Function

'Private Sub SetValidation()
'    Dim lNextValue As Long
'    lNextValue = GetNextValue
'
'    With GetMatrixRange.Validation
'        .Delete
'        .Add Type:=xlValidateWholeNumber, _
'             AlertStyle:=xlValidAlertStop, _
'             Operator:=xlEqual, _
'             Formula1:=lNextValue
'        .IgnoreBlank = True
'        .InCellDropdown = False
'        .InputTitle = "Next number"
'        .ErrorTitle = "Error"
'        .InputMessage = lNextValue
'        .ErrorMessage = "Next number is: " & lNextValue
'        .ShowInput = True
'        .ShowError = True
'    End With
'End Sub
'
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'    SetValidation
'End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error GoTo ErrorHandler
    Application.EnableEvents = False
    If Not Intersect(Target, GetMatrixRange) Is Nothing Then
        If Target = Empty Then Target.Value = GetNextValue
        Cancel = True
    End If
ErrorHandler:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    Application.EnableEvents = False
    
    Dim rWatched As Range: Set rWatched = Intersect(Target, GetMatrixRange)
    Dim lNextValue As Long
    Dim lEnteredValue As Long
    
    
    If Not rWatched Is Nothing Then
        Target.Select
        If rWatched.Cells.Count > 1 Then
            rWatched.ClearContents
            MsgBox "You cannot change more than 1 matrix cell at a time"
        ElseIf Not IsNumeric(rWatched.Value) Then
            rWatched.ClearContents
            MsgBox "Only numeric values allowed"
        Else
            If rWatched.Value <> Empty Then
                lEnteredValue = rWatched.Value
                rWatched.ClearContents
                lNextValue = GetNextValue
                If lEnteredValue <> lNextValue Then
                    If MsgBox("The next allowed value is: " & lNextValue & ". Do you want to accept it?", vbYesNo) = vbYes Then
                        rWatched.Value = lNextValue
                    End If
                Else
                    rWatched.Value = lEnteredValue
                End If
            End If
        End If
    End If

ErrorHandler:
    Application.EnableEvents = True
End Sub

我用双击和更改事件处理程序替换了验证代码。如果需要，请随意删除这些处理程序并取消注释验证和选择更改代码。

此代码将执行以下操作：

如果您更改矩阵中的任何单元格，它将验证它并给出您可以选择接受允许的值。否则会删除您输入的内容。
如果您双击矩阵中的一个单元格，它将填充下一个值

打开 Excel 时内存泄漏 - 导致崩溃

1 个答案: