Excel VBA：自动编号

Question

我正在 Excel 上创建一个数据库，但在尝试为每一行分配自动编号时遇到了一些问题。

要求是：

1. 当 B 列不为空时，为每一行（在 A 列上）生成自动编号。
2. 编号应该是唯一的，并且必须始终连接到同一行的内容，即使在对列进行排序或插入新行等时也是如此。
3. 插入新行时（同一列的任意位置），应分配新编号（最新编号应为最大编号） 如果
4. 可以，汽车号码应该有前缀，并且号码应该显示为四位数字（例如0001、0011）

我尝试了一些从其他人的问题中找到的 VBA 代码（例如 Excel VBA : Auto Generating Unique Number for each row）。

到目前为止，下面的代码效果最好，但该代码无法解决要求 (3) 和 (4)。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim maxNumber
If Not Intersect(Target, Range("B:B")) Is Nothing Then
' don't run when more than one row is changed
    If Target.Rows.Count > 1 Then Exit Sub
' if column A in the current row has a value, don't run
    If Cells(Target.Row, 1) > 0 Then Exit Sub
' get the highest number in column A, then add 1 and write to the
' current row, column A
    maxNumber = Application.WorksheetFunction.Max(Range("A:A"))
    Target.Offset(0, -1) = maxNumber + 1
End If
End Sub

我缺乏VBA知识，希望有人可以帮助我。 非常感谢。

Answer 1

不要使用 Max() 来查找下一个数字 - 而是使用隐藏的工作表或名称来存储当前数字，并在每次需要新 Id 时递增它。

例如：

Public Function NextNumber(SequenceName As String)
    Dim n As Name, v
    On Error Resume Next
    Set n = ThisWorkbook.Names(SequenceName)
    On Error GoTo 0

    If n Is Nothing Then
        'create the name if it doesn't exist
        ThisWorkbook.Names.Add SequenceName, RefersTo:=2
        v = 1
    Else
        'increment the current value
        v = Replace(n.RefersTo, "=", "")
        n.RefersTo = v + 1
    End If
    NextNumber = v
End Function

这允许您使用多个不同的序列，只要您给每个序列一个不同的名称。

Dim seq
seq = NextNumber("seqOne")
'etc

Answer 2

通过CustomDocumentProperties替代

不使用@TimWilliams 建议的隐藏表，可以将递增的值分配给用户定义的自定义文档属性 (CDP)，将其命名为例如"InvNo" 持有最新的发票号码。 cdp 仍存储在 已保存 工作簿中。

下面的函数获取保存到此工作簿相关属性的当前数字，并通过将当前值加1来返回下一个数字。它使用帮助程序RefreshCDP 来分配新值（当然可以独立使用，以编程方式将值重置为任何其他值）。 - 如果 cdp 名称未作为（可选）参数传递，则函数默认采用 "InvNo"。

请注意，代码需要一些错误处理来检查 cdp 是否存在。

调用示例

Dim InvoiceNumber as Long
InvoiceNumber = NextNumber("InvNo")    ' or simply: NextNumber

Public Function NextNumber(Optional CDPName As String = "InvNo") As Long

    'a) get current cdp value
    Dim curVal As Long
    On Error Resume Next
    curVal = ThisWorkbook.CustomDocumentProperties(CDPName)
    If Err.Number <> 0 Then Err.Clear            ' not yet existing, results in curVal of 0

    'b) increment current cdp value by one to simulate new value
    Dim newVal As Long
    newVal = curVal + 1
    'Debug.Print "Next " & CDPName & " will be: " & newVal

    'c) assign new value to custom document property
    RefreshCDP CDPName, newVal, msoPropertyTypeNumber
    'Debug.Print "New  " & CDPName & " now  is: " & ThisWorkbook.CustomDocumentProperties(CDPName)
    NextNumber = newVal
    
End Function

帮助程序RefreshCDP

Sub RefreshCDP(CDPName As String, _
    newVal As Variant, docType As Office.MsoDocProperties)
    On Error Resume Next
    ThisWorkbook.CustomDocumentProperties(CDPName).Value = newVal
    'If cdp doesn't exist yet, create it (plus adding the new value)
    If Err.Number > 0 Then
        ThisWorkbook.CustomDocumentProperties.Add _
            Name:=CDPName, _
            LinkToContent:=False, _
            Type:=docType, _
            Value:=newVal
    End If
End Sub

相关链接

• MS help: Excel.Workbook.CustomDocumentProperties
• Check if BuiltInDocumentProperty is set without error trapping
• Chip Pearson: Document Properties
• How to add a DocumentProperty to CustomDocumentProperties in Excel?