按指定数量批量自动填充的问题

kkjjboy

VBA小白，求助大神们，解决重复劳动问题，感谢！原始数据及想要生成的结果见附件，感谢，感谢，感谢！

yes363001640

这么样么？

cqlpjxx

Sub xx()
Dim arr, brr(1 To 10000, 1 To 6), i, j, n, str1, str2
arr = Sheet1.Range("A4:E" & Sheet1.Range("A65536").End(xlUp).Row)
n = 0
For i = 1 To UBound(arr)
str1 = arr(i, 1) & "-"
str1 = Mid(arr(i, 1), 1, InStr(1, str1, "-") - 1)
str2 = arr(i, 4) & "-"
str2 = Mid(arr(i, 4), 2, InStr(1, str2, "-") - 2)
  For j = 1 To arr(i, 2)
     n = n + 1
     brr(n, 1) = arr(i, 1)
     brr(n, 2) = 1
     brr(n, 3) = arr(i, 3)
     brr(n, 4) = arr(i, 4)
     brr(n, 5) = arr(i, 5)
     brr(n, 6) = str1 & "L" & Format(str2 + j - 1, "00000")
  Next
Next
Sheet1.Range("r4").Resize(1000, 6) = ""
Sheet1.Range("r4").Resize(1000, 6) = brr

End Sub

cqlpjxx

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

renkangjizhen

Sub ttt()
Dim arr, i%, m%, n%, x%, y%, z%, k%, q%
i = [a65536].End(3).Row
arr = Range("a4:e" & i)
For m = 1 To UBound(arr)
   
    x = Mid(arr(m, 4), 5, 2)
    q = InStr(1, arr(m, 1), "-")
    If q = 0 Then q = Len(arr(m, 1)) + 1
    For n = 1 To arr(m, 2)
        k = k + 1
        Cells(k + 3, "k") = arr(m, 1)
        Cells(k + 3, "l") = 1
        Cells(k + 3, "m") = arr(m, 3)
        Cells(k + 3, "n") = arr(m, 4)
        Cells(k + 3, "o") = arr(m, 5)
        Cells(k + 3, "p") = Left(arr(m, 1), q - 1) & "L000" & x
        x = x + 1
    Next n
Next m
End Sub

kkjjboy

cqlpjxx 发表于 2020-1-17 15:48
.............................

brr(n, 6) = str1 & "L" & Format(str2 + j - 1, "00000")
后面的编码不一定是& “L”    也有可能是K  或者其他字母的。

感谢指点呀。

kkjjboy

yes363001640 发表于 2020-1-17 15:22
这么样么？

差不多，但中间的000，这几位数能不少掉吗？    正确：A30TP1L00076   错误：A30TP1L76

yes363001640

kkjjboy 发表于 2020-1-17 16:52
差不多，但中间的000，这几位数能不少掉吗？    正确：A30TP1L00076   错误：A30TP1L76

那3个0还是要的，对吗？

yes363001640

不需要改了吧，楼上有很多大神的可以用吧

kkjjboy

yes363001640 发表于 2020-1-17 17:02
不需要改了吧，楼上有很多大神的可以用吧

可以了，有大神的可以用，感谢！