创build一个取决于当前年份的编号系统

我的电子表格用于pipe理任务。 我通过运行一个小的macros来添加新的任务,目前编号仅仅是1,2,3,4 …,由以下代码生成:

Cells(ActiveSheet.Rows(9).Row, 1).Value = Cells(ActiveSheet.Rows(10).Row, 1).Value + 1 

我希望使用VBA ,通过为代表任务开始年的数字添加一个前缀来演变。 此外,每年的第一次编号应该从1开始重新编号。 即

 15-1, 15-2, 15-3, 15-4....16-1, 16-2, 16-3... 

任何想法可以实现这个简单的代码?

这是一个非常基本的例子。 修改它以适应您的需求。 您也可以创build一个过程,并传递您希望自动编号发生的行号,如本文末尾所示。

 Sub Sample() Dim rng As Range Dim prev As Range Dim rw As Long rw = 9 '<~~ Change this to the relevant row Set rng = ThisWorkbook.Sheets("Sheet1").Cells(rw, 1) On Error Resume Next Set prev = rng.Offset(-1) On Error GoTo 0 '~~> Check if there is one row above If Not prev Is Nothing Then '~~> Match the year If Left(rng.Offset(-1), 2) <> Format(Date, "yy") Then '~~> Restart numbering rng.Value = Format(Date, "yy") & "-" & 1 Else '~~> Increment numbering. Split will extract the number rng.Value = Format(Date, "yy") & "-" & Val(Split(rng.Value, "-")(1)) + 1 End If Else '~~> Restart numbering rng.Value = Format(Date, "yy") & "-" & 1 End If End Sub 

截图

在这里输入图像说明

编辑:

将它用作可以传递参数的过程。

 Sub Sample() Dim r As Long r = 9 '<~~ Chnage this to the relevant row AllocateID r End Sub Sub AllocateID(rw As Long) Dim rng As Range Dim prev As Range Set rng = Cells(rw, 1) On Error Resume Next Set prev = rng.Offset(-1) On Error GoTo 0 '~~> Check if there is one row above If Not prev Is Nothing Then '~~> Match the year If Left(rng.Offset(-1), 2) <> Format(Date, "yy") Then '~~> Restart numbering rng.Value = Format(Date, "yy") & "-" & 1 Else '~~> Increment numbering. Split will extract the number rng.Value = Format(Date, "yy") & "-" & Val(Split(rng.Value, "-")(1)) + 1 End If Else '~~> Restart numbering rng.Value = Format(Date, "yy") & "-" & 1 End If End Sub 

这个怎么样:

 Sub Test() Dim i As Integer Dim startYear As Integer priorYear = 2014 With ActiveSheet For i = 1 To 100 .Cells(i, 1) = CStr(priorYear + WorksheetFunction.RoundUp(i / 12, 0) & "-" & ((i + 1) Mod 12)) Next i End With End Sub 

当然可以这样做:

 Cells(ActiveSheet.Rows(9).Row, 1).Value = format(date,"yy") & "-" & _ Cells(ActiveSheet.Rows(10).Row, 1).Value + 1