Board logo

標題: 貼入製造號碼後自動於G2產生填滿效果 [打印本頁]
作者: 霸氣走全身    時間: 2010-9-2 00:01     標題: 貼入製造號碼後自動於G2產生填滿效果

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

  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
複製代碼
作者: 霸氣走全身    時間: 2010-9-5 09:54

回復 2# Hsieh


dear Hsieh
謝謝你喔~~
真的可以耶
^^
作者: toomellowhaw    時間: 2010-9-10 22:09

權限不足，無法下載你的檔案，所以暫時假定你的製造號碼貼在[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),"")
作者: 霸氣走全身    時間: 2011-3-25 00:09

回復 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    時間: 2011-3-25 11:21

回復 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    時間: 2011-3-26 13:58

樓主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

  13. Range("h2").Activate

  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

  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

  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

  21. Range("L2").Activate

  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

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)