Question

我在电子表格中有2列列A是一个ID（每个新记录增加一个） B列是城市的名称

当新的城市被添加到B列时（并且只有当B列发生变化时），ID才会自动填充一个大于前一个记录的值。例如，如果我有当前记录集：

   A    B
   ________
1 | ID  City
2 | 1   London
3 | 2   Paris
4 | 3   New York

我将莫斯科添加到列表中，然后值4将自动填入A列？

   A    B
   ________
1 | ID  City
2 | 1   London
3 | 2   Paris
4 | 3   New York
5 | **4**   Moscow

它需要基于范围，所以我可以输入尽可能多的新记录。我已经尝试过Private Sub Worksheet_SelectionChange，但无法让它工作。

任何帮助将不胜感激非常感谢

Answer 1

实施Worksheet_Change事件宏时，需要考虑一些事项。

当您计划在事件宏中更改/删除/添加任何值到工作表时，首先要考虑的是您将触发另一个事件并且Worksheet_Change将尝试在其自身上运行。在更改工作表中的任何内容之前，始终使用Application.EnableEvents = False禁用事件处理并记住在离开事件宏之前再次使用Application.EnableEvents = True将其重新打开，否则在事件处理重新打开之前，任何未来事件都不会触发另一个Worksheet_Change

要考虑的第二件事是如何处理接收更改的单个单元。如果将多个值粘贴到B列中，则可能会发生这种情况。您还需要隔离仅粘贴到B列的值;可以想象其他列可以同时接收值。

如果清除城市值并在城市列中检查重复项，则如何处理ID是您应该考虑采取适当措施的其他注意事项。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(2)) Is Nothing Then
        On Error GoTo bm_Safe_Exit
        Application.EnableEvents = False
        Dim cty As Range
        For Each cty In Intersect(Target, Columns(2))
            If CBool(Len(cty.Value2)) Then
                cty.Offset(0, -1) = Application.Max(Columns(1)) + 1
                'check for duplicates and mark xlRed if found
                'comment or delete this if not required
                If Application.CountIf(Columns(2), cty.Value2) > 1 Then
                    cty.Interior.Color = vbRed
                Else
                    cty.Interior.Pattern = xlNone
                End If
            Else
                'not sure whether you want to clear the
                'ID column if the city column is cleared
                cty.Offset(0, -1).ClearContents
                'or clear any background fill from a duplicate
                cty.Interior.Pattern = xlNone
            End If
        Next cty
    End If
bm_Safe_Exit:
    Application.EnableEvents = True
End Sub

虽然我使用application.Max来确保唯一编号，但可以手动编辑A列中的ID，而不会受到事件宏的任何干扰。

使用Worksheet_Change可以做很多事情。上面是一个非常好的框架，可以帮助您入门，并且您应该能够扩展其功能，同时在线条内着色＆＃39;。

Answer 2

将其复制到vba中的工作表中

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim xrow As Long

    xrow = 2
    Set KeyCells = Range("B:B")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
        Do
            If Cells(xrow, 2).Value <> "" Then
                If Cells(xrow, 1).Value = "" Then
                    Cells(xrow, 1).Value = Cells(xrow - 1, 1).Value + 1
                End If
            End If
        xrow = xrow + 1
        Loop Until Cells(xrow, 2) = ""
    End If
End Sub

希望我帮助过：）

当另一个单元格被填充时，VBA自动填充单元格

2 个答案: