VBA对序列号进行分段，谢谢！

chxw68

1. Public d1 As Object
   
2. Public d2 As Object
   
3. Sub test1()
   
4.   Dim r&, i&, m&
   
5.   Dim brr(), crr()
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   Set d2 = CreateObject("scripting.dictionary")
   
10.   tt = Timer
    
11.   ss = ("0123456789ABCDEFGHJKLMNPQRSTUVWXYZ")
    
12.   For i = 1 To Len(ss)
    
13.     ch = Mid(ss, i, 1)
    
14.     d1(ch) = i - 1
    
15.     d2(i - 1) = ch
    
16.   Next
    
17.   With Worksheets("sheet1")
    
18.     gdz = .Range("c4")
    
19.     ksm = c34to10(.Range("d4"))
    
20.     jsm = c34to10(.Range("d5"))
    
21.     ReDim brr(1 To jsm - ksm + 1)
    
22.     m = 0
    
23.     For i = ksm To jsm
    
24.       m = m + 1
    
25.       brr(m) = gdz & c10to34(i)
    
26.     Next
    
27.     ReDim crr(1 To 2000, 1 To Application.Ceiling(UBound(brr) / 2000, 1))
    
28.     m = 1
    
29.     n = 1
    
30.     For i = 1 To UBound(brr)
    
31.       crr(m, n) = brr(i)
    
32.       m = m + 1
    
33.       If m > 2000 Then
    
34.         n = n + 1
    
35.         m = 1
    
36.       End If
    
37.     Next
    
38.     .Range("g3").Resize(UBound(crr), UBound(crr, 2)) = crr
    
39.   End With
    
40.   Application.ScreenUpdating = True
    
41.   MsgBox "共用时" & Timer - tt & "秒"
    
42. End Sub
    
43. Function c34to10(ByVal c34 As String) As Long
    
44.   Dim r%, i%
    
45.   Dim s As Long
    
46.   c34 = UCase(c34)
    
47.   For i = 1 To Len(c34)
    
48.     ch = Mid(c34, i, 1)
    
49.     s = s + d1(ch) * 34 ^ (Len(c34) - i)
    
50.   Next
    
51.   c34to10 = s
    
52. End Function
    
53. Function c10to34(ByVal c10 As Long) As String
    
54.   Dim s$
    
55.   Do While c10 > 33
    
56.     n = c10 Mod 34
    
57.     c10 = Int(c10 / 34)
    
58.     s = d2(n) & s
    
59.   Loop
    
60.   s = d2(c10) & s
    
61.   c10to34 = s
    
62. End Function
    
63. 
    

复制代码

chxw68

1. Sub test2()
   
2.   Dim r%, i%, m%, n%
   
3.   Dim gdz$, ksm$, jsm$
   
4.   Dim brr(1 To 2000, 1 To 3000)
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   Set d2 = CreateObject("scripting.dictionary")
   
9.   tt = Timer
   
10.   ss = ("0123456789ABCDEFGHJKLMNPQRSTUVWXYZ")
    
11.   For i = 1 To Len(ss)
    
12.     ch = Mid(ss, i, 1)
    
13.     d1(ch) = i - 1
    
14.     d2(i - 1) = ch
    
15.   Next
    
16.   
    
17.   With Worksheets("sheet1")
    
18.     gdz = .Range("c4")
    
19.     ksm = .Range("d4")
    
20.     jsm = .Range("d5")
    
21.     m = 1
    
22.     n = 1
    
23.     Do
    
24.       brr(m, n) = gdz & ksm
    
25.       m = m + 1
    
26.       If m > 2000 Then
    
27.         m = 1
    
28.         n = n + 1
    
29.       End If
    
30.       c34add ksm, Len(ksm)
    
31.     Loop While ksm <> jsm
    
32.     .Range("g3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
33.   End With
    
34.   Application.ScreenUpdating = True
    
35.   MsgBox "共用时" & Timer - tt & "秒"
    
36. End Sub
    
37. 
    
38. Sub c34add(ByRef c34 As String, ByVal n As Integer)
    
39.   ch = Mid(c34, n, 1)
    
40.   If d1(ch) < 33 Then
    
41.     c34 = Application.Replace(c34, n, 1, d2(d1(ch) + 1))
    
42.   Else
    
43.     c34 = Application.Replace(c34, n, 1, "0")
    
44.     c34add c34, n - 1
    
45.   End If
    
46. End Sub
    

复制代码

chxw68

第一种算法先转换成10进制数相加生成数组，然后再转换成34进制，用时68秒。
第二种直接使用递归算法直接进行34制加法，用时90秒。

周进

chxw68 发表于 2020-7-5 11:59
第一种算法先转换成10进制数相加生成数组，然后再转换成34进制，用时68秒。
第二种直接使用递归算法直接进 ...

两个文本框中输入字符+回车键确定该文本输入完成，代码如何写？也就是textbox1与textbox2两个文本框必须字符输入完然后按回车键才执行比较，目前问题是textbox2字符串未输入完程序就开始比较了

Option Explicit

Dim flag As Boolean

Private Sub TextBox1_Change()
  Call speak
End Sub

Private Sub TextBox2_Change()
  Call speak
End Sub

Sub speak()
  Dim t
  If Len(TextBox1.Text) = 0 Or Len(TextBox2.Text) = 0 Or flag Then Exit Sub
  If Mid(TextBox1.Text, 1, 7) = Mid(TextBox2.Text, 1, 7) Then
  Application.Speech.speak "ok"
  Else: Application.Speech.speak "不相同"
  End If
  t = Timer
  Do
    DoEvents
  Loop Until Timer - t >= 1
  TextBox1.Text = vbNullString
  TextBox2.Text = vbNullString
  flag = False
End Sub