Excel VBA 宏代码无限行插入不间断

Excel VBA Macro Code Inserting Unlimited Rows Without Stopping

当指定列中的单元格发生变化且不为空时,将自动运行以下代码。

Sub mergeCells()
    Dim num As Integer
    Dim countmerged As Integer
    If IsEmpty(ActiveCell.Value) Then
        Exit Sub
    Else
        countmerged = -1
        If ActiveCell.Offset(-1, 0).mergeCells Then
            countmerged = ActiveCell.Offset(-1, 0).MergeArea.Cells.Count * -1
        End If
        num = ActiveCell.Offset(countmerged, -1).Value
        If ActiveCell.Offset(countmerged, 0).Value = ActiveCell.Value Then
            ActiveCell.ClearContents
            ActiveCell.Offset(0, 1).ClearContents
            ActiveCell.Offset(0, 37).ClearContents
            ActiveCell.Offset(0, 36).ClearContents
            ActiveCell.Offset(0, -1).ClearContents
            ActiveCell.Offset(1, 0).EntireRow.Insert
            ActiveCell.Offset(2, 0).EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
            Range(ActiveCell.Offset(countmerged, 37), ActiveCell.Offset(0, 37)).Merge
            Range(ActiveCell.Offset(countmerged, 36), ActiveCell.Offset(0, 36)).Merge
            Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(countmerged, 1)).Merge
            Range(ActiveCell.Offset(countmerged, -1), ActiveCell.Offset(0, -1)).Merge
            Range(ActiveCell, ActiveCell.Offset(countmerged, 0)).Merge
            ActiveCell.Offset(1, -1).Value = num + 1
            ActiveCell.Offset(2, -1).Value = num + 2
        Else
            ActiveCell.Offset(1, 0).EntireRow.Insert
            ActiveCell.Offset(2, 0).EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
            Selection.Offset(1, -1).Value = num + 2
            Selection.Offset(2, -1).Value = num + 3
        End If
    End If
End Sub

如果该值与上述单元格的值相同,则合并它们并插入具有相同公式的另一行。这没有问题。

但如果数值与上述单元格不相同,则只需插入一行相同的公式,但它会不停地添加行。

我不认为您向我们展示了代码的重要部分(这使这部分关闭)。

我会尝试禁用事件,因为宏可能会更改一个单元格并看到一个单元格已更改(插入,无论如何)再次开始您的事件。

尝试在宏的开头和结尾添加这些。

Application.EnableEvents = False  


Application.EnableEvents = True