[已解决]做个自动编写入库单号的按钮，请大神给段代码

透明世界1987

自动编写入库单号.zip (349.02 KB, 下载次数: 10)

2022-5-14 19:58 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-5-15 11:39

Sub 自动编号()
  Dim Arr, Rc%, K%, gys, dhd, Rq, Dic, StrRq$, Str$
  Dim ShCs As Worksheet
  Dim ShZzb As Worksheet
  Set Dic = CreateObject("scripting.dictionary")
  Set gys = CreateObject("scripting.dictionary")
  Set dhd = CreateObject("scripting.dictionary")
  Set Rq = CreateObject("scripting.dictionary")
  Set ShCs = Worksheets("参数页")
  Set ShZzb = Worksheets("供应商交期追踪表")
  Arr = ShCs.Range("A1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    gys(Arr(Rc, 1)) = Arr(Rc, 2)
  Next Rc
  Arr = ShCs.Range("E1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    dhd(Arr(Rc, 1)) = Arr(Rc, 2)
  Next Rc
  Arr = ShZzb.Range("A7").CurrentRegion
  K = 0
  For Rc = 2 To UBound(Arr)
    StrRq = Format(Arr(Rc, 8), "yymmdd")
    Str = Arr(Rc, 3) & StrRq
      If Dic.exists(Str) Then
        Arr(Rc, 12) = StrRq & gys(Arr(Rc, 3)) & "-" & dhd(Arr(Rc, 7)) & Format(Dic(Str), "000")
      Else
        K = K + 1
        Dic(Str) = K
        Arr(Rc, 12) = StrRq & gys(Arr(Rc, 3)) & "-" & dhd(Arr(Rc, 7)) & Format(K, "000")
      End If
  Next Rc
  ShZzb.Range("A7").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  Set ShCs = Nothing
  Set ShZzb = Nothing
End Sub

跳转到最佳答案楼层

hasyh2008

Sub 自动编号()
  Dim Arr, Rc%, K%, gys, dhd, Rq, Dic, StrRq$, Str$
  Dim ShCs As Worksheet
  Dim ShZzb As Worksheet
  Set Dic = CreateObject("scripting.dictionary")
  Set gys = CreateObject("scripting.dictionary")
  Set dhd = CreateObject("scripting.dictionary")
  Set Rq = CreateObject("scripting.dictionary")
  Set ShCs = Worksheets("参数页")
  Set ShZzb = Worksheets("供应商交期追踪表")
  Arr = ShCs.Range("A1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    gys(Arr(Rc, 1)) = Arr(Rc, 2)
  Next Rc
  Arr = ShCs.Range("E1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    dhd(Arr(Rc, 1)) = Arr(Rc, 2)
  Next Rc
  Arr = ShZzb.Range("A7").CurrentRegion
  K = 0
  For Rc = 2 To UBound(Arr)
    StrRq = Format(Arr(Rc, 8), "yymmdd")
    Str = Arr(Rc, 3) & StrRq
      If Dic.exists(Str) Then
        Arr(Rc, 12) = StrRq & gys(Arr(Rc, 3)) & "-" & dhd(Arr(Rc, 7)) & Format(Dic(Str), "000")
      Else
        K = K + 1
        Dic(Str) = K
        Arr(Rc, 12) = StrRq & gys(Arr(Rc, 3)) & "-" & dhd(Arr(Rc, 7)) & Format(K, "000")
      End If
  Next Rc
  ShZzb.Range("A7").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  Set ShCs = Nothing
  Set ShZzb = Nothing
End Sub

zt1066815277

不知道能否满足你的需求,水平有限,不对勿怪.

1. Sub 自动编号()
   
2.     Dim d As New Dictionary, arr, brr, crr
   
3.     Dim gys, dhd, sj As String, jsNum%
   
4.     arr = Sheets("参数页").Cells.CurrentRegion
   
5.     brr = Sheets("参数页").Range("e1").CurrentRegion
   
6.     Sheets("供应商交期追踪表").Range("l8:l200").ClearContents
   
7.     For i = 2 To UBound(arr)
   
8.         d(arr(i, 1)) = arr(i, 2)
   
9.     Next
   
10.     For i = 2 To UBound(brr)
    
11.         d(brr(i, 1)) = brr(i, 2)
    
12.     Next
    
13.      With Sheets("供应商交期追踪表")
    
14.         .Range("a7:p110").Sort Range("c1"), 1, Range("k1"), , 2, Header:=xlYes
    
15.         crr = .Range("a7").CurrentRegion
    
16.          jsNum = 1
    
17.          .Cells(8, 12) = Format(.Cells(8, 11), "yyyymmdd") & d(crr(8, 3)) & "-" & d(crr(8, 7)) & Right("000" & jsNum, 3)
    
18.         For i = 3 To UBound(crr)
    
19.             gys = crr(i, 3)
    
20.             dhd = crr(i, 7)
    
21.             sj = crr(i, 11)
    
22.              If sj <> "" Then
    
23.                     If crr(i, 11) = crr(i - 1, 11) Then
    
24.                         jsNum = jsNum + 1
    
25.                         .Cells(i + 6, 12) = Format(sj, "yyyymmdd") & d(gys) & "-" & d(dhd) & Right("000" & jsNum, 3)
    
26.                     Else
    
27.                         jsNum = 1
    
28.                         .Cells(i + 6, 12) = Format(sj, "yyyymmdd") & d(gys) & "-" & d(dhd) & Right("000" & jsNum, 3)
    
29.                     End If
    
30.             End If
    
31.         Next
    
32.     End With
    
33. End Sub

复制代码

金樽空对月

1. Sub mynumber()
   
2. Dim d1, d2 As Object, ar, br, cr, i%, m%, n%
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. ar = Sheets("供应商交期追踪表").Range("a8:p" & Sheets("供应商交期追踪表").Range("a100000").End(3).Row)
   
6. br = Sheets("参数页").Range("a2:b" & Sheets("参数页").Range("a100000").End(3).Row)
   
7. cr = Sheets("参数页").Range("e2:f" & Sheets("参数页").Range("e100000").End(3).Row)
   
8. For i = 1 To UBound(br)
   
9.     d1(br(i, 1)) = br(i, 2)
   
10. Next i
    
11. For m = 1 To UBound(cr)
    
12.     d2(cr(m, 1)) = cr(m, 2)
    
13. Next m
    
14. For n = 1 To UBound(ar)
    
15.     ar(n, 12) = Format(ar(n, 8), "yymmdd") & d1(ar(n, 3)) & "-" & d2(ar(n, 7)) & Format(n, "000")
    
16. Next
    
17. Sheets("供应商交期追踪表").Range("a8").Resize(UBound(ar, 1), UBound(ar, 2)) = ar
    
18. End Sub

复制代码

透明世界1987

hasyh2008 发表于 2022-5-15 11:39
Sub 自动编号()
  Dim Arr, Rc%, K%, gys, dhd, Rq, Dic, StrRq$, Str$
  Dim ShCs As Worksheet

感谢大神基本可以用，就是同一个供应商，到货地不同，序列号可以不一样吗 不然眼镜都看花了呀，就是说比如奥德普到货和昌序号001  那么到货御墅序号就换下002了，不然仅仅只是中间字母差距，很容易看花

hasyh2008

Sub 自动编号()
  Dim Arr, Rc%, K%, gys, dhd, Rq, Dic, StrRq$, Str$
  Dim ShCs As Worksheet
  Dim ShZzb As Worksheet
  Set Dic = CreateObject("scripting.dictionary")
  Set gys = CreateObject("scripting.dictionary")
  Set dhd = CreateObject("scripting.dictionary")
  Set Rq = CreateObject("scripting.dictionary")
  Set ShCs = Worksheets("参数页")
  Set ShZzb = Worksheets("供应商交期追踪表")
  Arr = ShCs.Range("A1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    gys(Arr(Rc, 1)) = Arr(Rc, 2)
  Next Rc
  Arr = ShCs.Range("E1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    dhd(Arr(Rc, 1)) = Arr(Rc, 2)
  Next Rc
  Arr = ShZzb.Range("A7").CurrentRegion
  K = 0
  For Rc = 2 To UBound(Arr)
    StrRq = Format(Arr(Rc, 8), "yymmdd")
    Str = Arr(Rc, 3) & Arr(Rc, 7) & StrRq
      If Dic.exists(Str) Then
        Arr(Rc, 12) = StrRq & gys(Arr(Rc, 3)) & "-" & dhd(Arr(Rc, 7)) & Format(Dic(Str), "000")
      Else
        K = K + 1
        Dic(Str) = K
        Arr(Rc, 12) = StrRq & gys(Arr(Rc, 3)) & "-" & dhd(Arr(Rc, 7)) & Format(K, "000")
      End If
  Next Rc
  ShZzb.Range("A7").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  Set ShCs = Nothing
  Set ShZzb = Nothing
End Sub

透明世界1987

hasyh2008 发表于 2022-5-15 11:39
Sub 自动编号()
  Dim Arr, Rc%, K%, gys, dhd, Rq, Dic, StrRq$, Str$
  Dim ShCs As Worksheet

有么有可能不重复出单号，比如现在做点一下出来001   002   003   过一会做出来还是001-003能自动成为004   005这样循环下去次日清零