貼入製造號碼後自動於G2產生填滿效果

霸氣走全身

請問一下
貼入製造號碼後自動於G2產生填滿效果
10005874-1-6
於G2自動產生
10005874-1
10005874-2
10005874-3
10005874-4
10005874-5
10005874-6
是用函數還是巨集才可以呢
如附件
請幫忙~~~
謝謝

Hsieh

1. Sub getmynumber()
   
2. Dim Ay(), A As Range, Ar As Variant, s&, i%
   
3. For Each A In Range([C2], [C65536].End(xlUp))
   
4.    If Len(A) - Len(Replace(A, "-", "")) = 2 Then
   
5.    Ar = Split(A, "-")
   
6.    For i = Val(Ar(1)) To Val(Ar(2))
   
7.       ReDim Preserve Ay(s)
   
8.       Ay(s) = Ar(0) & "-" & i
   
9.       s = s + 1
   
10.    Next
    
11.    Else
    
12.       ReDim Preserve Ay(s)
    
13.       Ay(s) = A
    
14.       s = s + 1
    
15.    End If
    
16. Next
    
17. [G2:G65536] = ""
    
18. [G2].Resize(s, 1) = Application.Transpose(Ay)
    
19. End Sub

複製代碼

霸氣走全身

回復 2# Hsieh


dear Hsieh
謝謝你喔~~
真的可以耶
^^

toomellowhaw

權限不足，無法下載你的檔案，所以暫時假定你的製造號碼貼在[G1]格內，那麼只要在[G2]格內輸入下列公式，再拖曳複製至所需列數即可....笨方法，請指教..
=IF(--(ROWS($2:2)+MID($G$1,FIND("-",$G$1)+1,FIND("-",$G$1,FIND("-",$G$1)+1)-FIND("-",$G$1)-1)-1)<=--RIGHT($G$1,LEN($G$1)-FIND("-",$G$1,FIND("-",$G$1)+1)),LEFT($G$1,FIND("-",$G$1)-1)&"-"&(ROWS($2:2)+MID($G$1,FIND("-",$G$1)+1,FIND("-",$G$1,FIND("-",$G$1)+1)-FIND("-",$G$1)-1)-1),"")

霸氣走全身

回復 2# Hsieh

請問你
如果是
客戶         尺寸     製造號碼            BP數
AAA        110*550        1009564-1         2
BBB        333*545        01006505-1-2        4
可以轉換成如下，BP數 2 轉換成2比同樣號碼，但是後面會以A~B區分~~BP數 4      會  A~B~C~D 區分              
AAA        110*550        1009564-1A
AAA        110*550        1009564-1B
BBB        333*545        01006505-1A
BBB        333*545        01006505-1B
BBB        333*545        01006505-1C
BBB        333*545        01006505-1D
BBB        333*545        01006505-2A
BBB        333*545        01006505-2B
BBB        333*545        01006505-2C
BBB        333*545        01006505-2D

這樣也可以嗎
再次麻煩妳了
謝謝

Hsieh

回復 5# 霸氣走全身

1. Sub SSS()
   
2. Dim Ay(), A As Range, Ar As Variant, s&, i%
   
3. For Each A In Range([D2], [D65536].End(xlUp))
   
4.    If Len(A) - Len(Replace(A, "-", "")) = 2 Then
   
5.    Ar = Split(A, "-")
   
6.    For i = Val(Ar(1)) To Val(Ar(2))
   
7.    For j = 1 To A.Offset(, 1)
   
8.    If A.Offset(, 1) > 1 Then temp = Chr(64 + j) Else temp = ""
   
9.       ReDim Preserve Ay(s)
   
10.       Ay(s) = Array(A.Offset(, -2).Value, A.Offset(, -1).Value, Ar(0) & "-" & i & temp)
    
11.       s = s + 1
    
12.    Next
    
13.    Next
    
14.    Else
    
15.    For j = 1 To A.Offset(, 1)
    
16.    If A.Offset(, 1) > 1 Then temp = Chr(64 + j) Else temp = ""
    
17.       ReDim Preserve Ay(s)
    
18.       Ay(s) = Array(A.Offset(, -2).Value, A.Offset(, -1).Value, A.Value & temp)
    
19.       s = s + 1
    
20.    Next
    
21.    End If
    
22. Next
    
23. [K2:M65536] = ""
    
24. [K2].Resize(s, 3) = Application.Transpose(Application.Transpose(Ay))
    
25. End Sub

複製代碼

FAlonso

樓主1樓

1. Sub abc()
   
2. Dim head(), body(), tail(), mycell As Range, i As Integer, j As Integer, k As Integer
   
3. For Each mycell In Range([c2], [c65536].End(xlUp))
   
4. ReDim Preserve head(i)
   
5. ReDim Preserve body(i)
   
6. ReDim Preserve tail(i)
   
7. head(i) = Split(mycell, "-")(0)
   
8. body(i) = Split(mycell, "-")(1)
   
9. tail(i) = Split(mycell, "-")(2)
   
10. i = i + 1
    
11. Next
    
12. 
    
13. Range("h2").Activate
    
14. 
    
15. For j = 0 To UBound(head)
    
16. For k = body(j) To tail(j)
    
17. ActiveCell.Value = head(j) & "-" & k
    
18. ActiveCell.Offset(1).Activate
    
19. Next
    
20. Next
    
21. 
    
22. End Sub

複製代碼

樓主5樓

1. Sub myprint()
   
2. Dim mycell As Range, head(), body(), tail(), BPnumber(), i As Integer
   
3. Dim j As Integer, bp As Integer, k As Integer, l As Integer
   
4. 
   
5. For Each mycell In Range([d2], [d65536].End(xlUp))
   
6. ReDim Preserve head(i)
   
7. ReDim Preserve body(i)
   
8. ReDim Preserve tail(i)
   
9. ReDim Preserve BPnumber(i)
   
10. head(i) = Split(mycell, "-")(0)
    
11. body(i) = Split(mycell, "-")(1)
    
12.     If UBound(Split(mycell, "-")) = 2 Then
    
13.     tail(i) = Split(mycell, "-")(2)
    
14.     Else
    
15.     tail(i) = ""
    
16.     End If
    
17. BPnumber(i) = mycell.Offset(, 1).Value
    
18. i = i + 1
    
19. Next
    
20. 
    
21. Range("L2").Activate
    
22. 
    
23. For j = 0 To UBound(head)
    
24.     If tail(j) = "" Then
    
25.         If BPnumber(j) = 1 Then
    
26.         ActiveCell = Cells(j + 2, 2).Value
    
27.         ActiveCell.Offset(, 1) = Cells(j + 2, 2).Offset(, 1).Value
    
28.         ActiveCell.Offset(, 2) = head(j) & "-" & body(j)
    
29.         ActiveCell.Offset(1).Activate
    
30.         Else
    
31.             For bp = 1 To BPnumber(j)
    
32.                 ActiveCell = Cells(j + 2, 2).Value
    
33.                 ActiveCell.Offset(, 1) = Cells(j + 2, 2).Offset(, 1).Value
    
34.                 ActiveCell.Offset(, 2) = head(j) & "-" & body(j) & Chr(64 + bp)
    
35.                 ActiveCell.Offset(1).Activate
    
36.             Next
    
37.         End If
    
38.     Else
    
39.         If BPnumber(j) = 1 Then
    
40.             For k = body(j) To tail(j)
    
41.                 ActiveCell = Cells(j + 2, 2).Value
    
42.                 ActiveCell.Offset(, 1) = Cells(j + 2, 2).Offset(, 1).Value
    
43.                 ActiveCell.Offset(, 2) = head(j) & "-" & k
    
44.                 ActiveCell.Offset(1).Activate
    
45.             Next
    
46.         Else
    
47.             For k = body(j) To tail(j)
    
48.                 For bp = 1 To BPnumber(j)
    
49.                  ActiveCell = Cells(j + 2, 2).Value
    
50.                  ActiveCell.Offset(, 1) = Cells(j + 2, 2).Offset(, 1).Value
    
51.                  ActiveCell.Offset(, 2) = head(j) & "-" & k & Chr(64 + bp)
    
52.                  ActiveCell.Offset(1).Activate
    
53.                  Next
    
54.             Next
    
55.         End If
    
56.     End If
    
57. Next
    
58. 
    
59. End Sub

複製代碼

土法大煉鋼,比較繁複和慢一點
另外5樓附檔D7一欄,最右手面有多餘空格,會影響結果,要小心處理