( 已解決 )重新編碼序號

vba 巨集重新編碼不跳號

chare168 2017-11-08 09:45:56 ‧ 7187 瀏覽

分享至

請問VBA 巨集寫法
請問如何將 XLS 用 VBA 巨集寫法重新將序號編碼不跳號
A1601002
A1601004
A1601004
A1601006
A1601006
A1601007
VBA重新編碼為
A1601001
A1601002
A1601002
A1601003
A1601003
A1601004
說明序號往前遞補不空號，
如第一筆後三碼002 自動編為後三碼001
如第二筆後三碼004 自動編為後三碼002
如第二筆後三碼004 自動編為後三碼002

登入發表討論

直播研討會

{{ item.channelVendor }} {{ item.webinarstarted }} |

直播中

2 個回答

海綿寶寶

iT邦大神 1 級 ‧ 2017-11-09 17:10:17

最佳解答

乍看以為是 two level break
其實只有一層 break

Option Explicit
Dim bRun As Boolean
Dim sGroup, sKey As String
Dim iIndex As Integer
Sub Main()
    '設定初值
    bRun = True
    sGroup = ""
    sKey = ""
    iIndex = 0
    '主迴圈,從 A1 開始往下
    Range("A1").Select
    Do While bRun
        sKey = ActiveCell.Value
        If (sKey <> sGroup) Then    '項次變動
            If (Left(sKey, 7) <> Left(sGroup, 7)) Then   '日期變動,重設 index 值
                iIndex = 1
            Else
                iIndex = iIndex + 1
            End If
            ActiveCell.Offset(0, 5).Value = Left(sKey, 7) & Format(iIndex, "000")
        Else
            ActiveCell.Offset(0, 5).Value = Left(sKey, 7) & Format(iIndex, "000")
        End If
        sGroup = sKey
        '下一筆
        ActiveCell.Offset(1, 0).Select
        '如果沒值就結束執行
        If IsEmpty(ActiveCell.Value) Then
            bRun = False
        End If
    Loop
    MsgBox "Done", vbInformation
End Sub

回應 5
分享
檢舉

看更多先前的回應...收起先前的回應...

小碼農米爾 iT邦高手 1 級 ‧ 2017-11-09 17:25:41 檢舉

趕快筆記，不會寫 VBA 還在查語法中

chare168 iT邦新手 4 級 ‧ 2017-11-10 09:40:43 檢舉

非常感謝您的幫忙完全無誤VB程式又快~比EXCEL程式快上百倍>>兩者多能得到相同正確解答
謝謝

海綿寶寶 iT邦大神 1 級 ‧ 2017-11-10 09:43:09 檢舉

此言差矣
基本上 VBA 是靠 Excel 才有一口飯吃的

chare168 iT邦新手 4 級 ‧ 2017-11-10 10:09:09 檢舉

謝謝您的幫忙
1.請問如何將發問移置已解決區
2.我看有說明給分，最佳答案(不知如何使用)

海綿寶寶 iT邦大神 1 級 ‧ 2017-11-10 10:31:26 檢舉

1.只要你選出「最佳解答」,發問就會自動移至已解決區
2.找一下，每個答案區域，應該有「選為最佳解答」的「按鈕」

登入發表回應

小碼農米爾

iT邦高手 1 級 ‧ 2017-11-08 20:08:02

沒有做出 VBA 倒是試出了 Excel 公式
B1公式 =VALUE(RIGHT(A1,3))
C1公式 =SUMPRODUCT((B$1:B$6<B1)*(1/COUNTIF(B$1:B$6,B$1:B$6)))+1
D1公式 =LEFT(A1,5)&TEXT(C1,"000")

回應 4
分享
檢舉

看更多先前的回應...收起先前的回應...

chare168 iT邦新手 4 級 ‧ 2017-11-09 09:39:40 檢舉

非常感謝您的幫忙>>(我想好久不知如何做起)
我在測試時發現 C1 公式改為B$1:B$20 沒問題>>超過20筆以上 #DIV/0!
PS: 資料可能是1-3萬筆或以上~~不知是否有方法可以抓取 B:B
謝謝

小碼農米爾 iT邦高手 1 級 ‧ 2017-11-09 09:49:43 檢舉

1-3萬筆阿，那規則呢?
目前我只取後面三位，所以只能排999筆~

小碼農米爾 iT邦高手 1 級 ‧ 2017-11-09 09:55:05 檢舉

=SUMPRODUCT((B$1:B$29<B1)*(1/COUNTIF(B$1:B$29,B$1:B$29)))+1
這三個地方要對應資料筆數，出現 #DIV/0! 應該是 B欄內有空白。
我自己測試999筆要跑很久，不過還是跑得出來，幾萬筆可能就真的要寫 VBA 了XD

chare168 iT邦新手 4 級 ‧ 2017-11-09 13:49:47 檢舉

例:一筆單頭 W160101001 (W單別 16年01月01日001流水號)單身會有多筆 W160101001 項次001~到xxx
因單據有跳號所以要往前遞補缺號 (一個月單身可能有1-3萬筆)
PS:(每日流水號多重001開始至xxx)
原編號項次 VBA重新編碼為項次
A160101002 001 A160101001 001
A160101004 001 A160101002 001
A160101004 002 A160101002 002
A160101006 001 A160101003 001
A160101006 002 A160101003 002
A160101007 001 A160101004 001
….. …….
A160131003 001 A160131001 001
A160131005 001 A160131002 001
A160131005 002 A160131002 002
A160131006 001 A160131003 001
A160131006 002 A160131003 002
A160131008 001 A160131004 001
以上說明-