用VBA批量生成序列码，目前我只会单个的，批量的还不会。请帮忙看看，谢谢

2728911088

根据上面的生成下面的。谢谢

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.9.3
   
2.     arr = Sheets("批号").UsedRange
   
3.     ReDim brr(1 To 10000, 1 To 2)
   
4.     For i = 2 To UBound(arr)
   
5.         st1 = arr(i, 1)
   
6.         num = arr(i, 2)
   
7.         For x = 1 To num
   
8.             m = m + 1
   
9.             brr(m, 1) = st1
   
10.             brr(m, 2) = st1 & Format(x, "00000")
    
11.         Next
    
12.     Next
    
13.     With Sheets("序列码")
    
14.         .UsedRange.Offset(1).ClearContents
    
15.         .Columns("a:b").NumberFormatLocal = "@"
    
16.         .[a2].Resize(m, 2) = brr
    
17.     End With
    
18.     MsgBox "OK！"
    
19. End Sub
    

复制代码

demonimissyou

Sub XX()
    Dim arr As Variant
    Dim i As Long, count As Long
    Dim temp As String, result As String
   
    i = Sheet4.[A65536].End(xlUp).Row
    arr = Sheet4.Range("A2:B" & i)
    count = 1
    temp = arr(1, 1)
   
    For i = 1 To UBound(arr)
        If temp = arr(i, 1) Then
            arr(i, 2) = temp & Format(CStr(count), "00000")
            count = count + 1
        Else
            count = 1
            temp = arr(i, 1)
            arr(i, 2) = temp & Format(CStr(count), "00000")
            count = count + 1
        End If
    Next i
   
    Sheet4.[A2].Resize(UBound(arr), 2) = arr
   
End Sub

大灰狼1976

1. Sub test()
   
2. Dim lot$, n&
   
3. lot = "7897890"
   
4. n = 5
   
5. [d2].Resize(n) = Evaluate(lot & "&text(row(1:" & n & "),""00000"")")
   
6. End Sub

复制代码

usedrange

1. Sub tt()
   
2.     Dim ar, i%, j%, r%
   
3.     ReDim ar(1 To 10000, 1 To 2)
   
4.     r = 1
   
5.     Sheets("序列码").[c:d].NumberFormat = "@"
   
6.     For i = 2 To [a1].End(4).Row
   
7.         For j = 1 To Cells(i, 2).Value
   
8.             ar(r, 1) = Cells(i, 1)
   
9.             ar(r, 2) = Cells(i, 1) & Format(j, "00000")
   
10.             r = r + 1
    
11.         Next j
    
12.     Next i
    
13.     Sheets("序列码").[c2].Resize(UBound(ar), 2) = ar
    
14. End Sub

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, n&
   
    Application.ScreenUpdating = False
   
    With Worksheets(1).[A1].CurrentRegion
        ar = .Value
        n = WorksheetFunction.Sum(.Columns(2))
        ReDim br(n, 1) As String
        br(0, 0) = "批号": br(0, 1) = "序列码"
    End With
   
    For i = 2 To UBound(ar)
        For j = 1 To ar(i, 2)
            r = r + 1
            br(r, 0) = ar(i, 1)
            br(r, 1) = ar(i, 1) & Format(j, "00000")
        Next j
    Next i
   
    [A1].CurrentRegion.Clear
    [A1].Resize(UBound(br) + 1, 2) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

..............

Qs18

Sub qs()
Dim arr, i, s
arr = Sheet1.UsedRange
ReDim brr(1 To 60000, 1 To 2)
For i = 2 To UBound(arr)
    s = arr(i, 1)
    For j = 1 To arr(i, 2)
        m = m + 1
        brr(m, 1) = s
        brr(m, 2) = "'" & s & Format(j, "00000")
    Next
Next
With Sheet2
    .Range("a2").Resize(10000, 2).ClearContents
    .Range("a2").Resize(m, 2) = brr
End With
End Sub

Qs18

试试..........