Excel VBA 自动添加新行并递增ID

Excel VBA 自动添加新行并递增ID

Sub AutoInsert()
Line = 1531
Count = Cells(Line, 5).Value
''Count = 5

For i = 2 To Count
''Copy
Range(Cells(Line + i - 2, 1), Cells(Line + i - 2, 6)).Select
Selection.Copy

''Insert
Range(Cells(Line + i - 1, 1), Cells(Line + i - 1, 6)).Rows.Insert

'' Change Id and Ip Cell Value
''Id: ESP004001
IdVal = Cells(Line + i - 1, 2).Value

If i = 2 And InStr(IdVal, "ESP") = 0 Then

''FH00318 ---> FH00318001
Cells(Line + i - 1, 2).Value = IdVal & "001"

Else

LastZeroPosInId = InStrRev(IdVal, "0")

IdPrefix = Left(IdVal, LastZeroPosInId)

If Len(IdVal) = LastZeroPosInId Then
IdValPart = 0
Else
IdValPart = Right(IdVal, Len(IdVal) - LastZeroPosInId)
End If

NewId = IdValPart + 1

''Remove one zero, if NewId lengthen.

If Len(NewId) + Len(IdPrefix) > Len(IdVal) Then
IdPrefix = Left(IdPrefix, Len(IdPrefix) - 1)
End If

Cells(Line + i - 1, 2).Value = IdPrefix & NewId
End If

''Ip: 202.123.176.63
IpVal = Cells(Line + i - 1, 4).Value
LastDotPos = InStrRev(IpVal, ".")
IpPrefix = Left(IpVal, LastDotPos)
IpValPart = Right(IpVal, Len(IpVal) - LastDotPos)

NewIp = IpValPart + 1

Cells(Line + i - 1, 4).Value = IpPrefix & NewIp

Next i

''ActiveWorkbook.Save
End Sub