Sub Macro1()
    Dim d As Object, d1 As Object, arr, i As Long, k As Long, r1 As Long
    xlapp.ScreenUpdating = False
    r1 = xlapp.Cells(xlapp.Rows.Count, 6).End(xlUp).Row
    arr = xlapp.Range("e" & 行 & ":f" & r1)
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    a = Left(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 4)
    b = Mid(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 5, 5)
    For i = 1 To UBound(arr)
        s = arr(i, 2)
        If Not d.Exists(s) Then k = k + 1: d1(s) = b + k
        d(s) = d(s) + 1
        arr(i, 1) = a & Format(d1(s), "00000") & d(s)
    Next
    For i = 1 To UBound(arr)
        s = arr(i, 2)
        If d(s) = 1 Then Mid(arr(i, 1), Len(arr(i, 1)), 1) = "0"
    Next
    xlapp.Range("e" & 行 & ":f" & r1) = arr
    xlapp.ScreenUpdating = True
End Sub

Sub Macro1()
    Dim arr, i&, j&, lr&, s$
    s = "K"
    With Range("B17:B" & Range("a65536").End(xlUp).Row)
        arr = .Value
        lr = UBound(arr)
        For i = 1 To lr Step 3
            m = m + 1
            n = 0
            For j = i To i + 2
                If j > lr Then Exit For
                n = n + 1
                arr(j, 1) = s & m & n
            Next
        Next
        .Value = arr
    End With
End Sub

Sub Macro1()
    Dim arr, brr(), wb As Excel.Workbook, sh As Excel.Worksheet, r As Long, i As Long, j As Long, mypath As String
    xlapp.ScreenUpdating = False
    Set sh = xlapp.ActiveSheet
    行 = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    mypath = xlapp.ActiveWorkbook.Path & "\"
    If Dir(mypath & "Book.xls") = "" Then
        MsgBox mypath & "Book.xls 不存在!"
        Exit Sub
    End If
    Set wb = GetObject(mypath & "Book.xls")
    With wb
        With .Worksheets(1)
            r = .UsedRange.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            arr = .Range("a3:bs" & r)
        End With
        .Close False
    End With
    m = 0
    For i = 1 To UBound(arr)
        For j = 1 To arr(i, 36)
            m = m + 1
            ReDim Preserve brr(1 To 9, 1 To m)
            brr(6, m) = arr(i, 4)
            brr(7, m) = arr(i, 63)
            brr(8, m) = arr(i, 54)
            brr(9, m) = arr(i, 55)
        Next
    Next
    sh.Range("a" & 行).Resize(UBound(brr, 2), UBound(brr)) = xlapp.Transpose(brr)
    xlapp.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
    Dim arr, i&, j&, d As Object
    Set d = CreateObject("scripting.dictionary")
    d(0) = "A"
    d(1) = "B"
    d("03") = "C"
    d("13") = "D"
    d("04") = "E"
    d("14") = "F"
    d("05") = "X"
    d("15") = "Y"
    d("25") = "Z"
    arr = [m5].CurrentRegion
    For i = 1 To UBound(arr)
        If d.Exists(arr(i, 1)) Then
            arr(i, 1) = d(arr(i, 1))
            arr(i, 2) = arr(i, 2) & "/" & arr(i, 2)
            For j = 3 To 5
                arr(i, j) = d(arr(i, j) & j)
            Next
        End If
    Next
    [m5].CurrentRegion = arr
End Sub

Private Sub CommandButton1_Click()
    Dim arr, i&, j&, d As Object
    Set d = CreateObject("scripting.dictionary")
    d(0) = "A"
    d(1) = "B"
    d("03") = "C"
    d("13") = "D"
    d("04") = "E"
    d("14") = "F"
    d("05") = "X"
    d("15") = "Y"
    d("25") = "Z"
    arr = [m5].CurrentRegion
    For i = 1 To UBound(arr)
        If d.Exists(arr(i, 1)) Then arr(i, 1) = d(arr(i, 1))
        If InStr(arr(i, 2), "/") = 0 Then arr(i, 2) = arr(i, 2) & "/" & arr(i, 2)
        For j = 3 To 5
            If d.Exists(arr(i, j) & j) Then arr(i, j) = d(arr(i, j) & j)
        Next
    Next
    [m5].CurrentRegion = arr
End Sub

原单元格值是数字的，直接使用的不用双引号，单元格值用“&”连接起来后就变成了字符串，而字符串常数表示方法要用用双引号
单元格值为1，列号为3，就是1&3="13"

[ 本帖最后由 sfadfa 于 2014-11-22 21:54 编辑 ]

Sub Macro1()
i = Range("A65536").End(xlUp).Row
Set m = Range("B65536").End(xlUp)
ReDim arr(1 To (i - m.Row), 1 To 1)
k = Left(m.Value, 4)
a = Mid(m.Value, 5, Len(m.Value) - 5)
L = Len(a)
a = a + 1
For j = 1 To i - m.Row
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
    If Len(a) < L Then
        For x = 1 To L - Len(a)
            a = "0" & a
        Next
    End If
    arr(j, 1) = k & a & n
Next
m.Offset(1, 0).Resize(j - 1, 1) = arr
End Sub

Private Sub CommandButton1_Click()
Dim arr(1 To 36), i&
arr(1) = Left([b16], Len([b16]) - 1) & 1
For i = 2 To UBound(arr)
  arr(i) = Left(arr(i - 1), Len(arr(i - 1)) - 3) & Format(Mid(arr(i - 1), Len(arr(i - 1)) - 2) + 1, "000")
  If Right(arr(i), 1) > 3 Then
  arr(i) = Left(arr(i - 1), Len(arr(i - 1)) - 3) & Format(Mid(arr(i - 1), Len(arr(i - 1)) - 2) + 8, "000")
  End If
Next
[e5].Resize(UBound(arr), 1) = Application.Transpose(arr)
End Sub

Sub test()
    Dim a, i, j, num, arr
    a = Sheets(1).Cells(60000, 1).End(xlUp).Row - 4
    ReDim arr(1 To a, 1 To 1)
    num = 32100206
    For i = 1 To a Step 3
        num = num + 1
        For j = 1 To 3
            If i + j - 2 < a Then arr(i + j - 1, 1) = "K" & num & j
        Next j
    Next i
    Sheets(1).Cells(5, 2).Resize(a) = arr
End Sub

Sub Macro1()
i = Range("A65536").End(xlUp).Row
ReDim arr(1 To i - 4, 1 To 1)
box = InputBox("请输入第一个标题编码：")
If box = "" Then End
n = Right(box, 1)
If n > 3 Then
    MsgBox "编码错误，尾数不能大于3！", vbOKOnly
    End
End If
k = Left(box, 1)
a = Mid(box, 2, Len(box) - 2)
For j = 1 To i - 4
    arr(j, 1) = k & a & n
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
Next
Range("B5:B" & i) = arr
End Sub

Sub Macro1()
i = Range("A65536").End(xlUp).Row
Set m = Range("B65536").End(xlUp)
ReDim arr(1 To (i - m.Row), 1 To 1)
n = Right(m.Value, 1)
k = Left(m.Value, 4)
a = Mid(m.Value, 5, Len(m.Value) - 5)
L = Len(a)
For j = 1 To i - m.Row
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
    If Len(a) < L Then
        For x = 1 To L - Len(a)
            a = "0" & a
        Next
    End If
    arr(j, 1) = k & a & n
Next
m.Offset(1, 0).Resize(j - 1, 1) = arr
End Sub