標題: [求助] 將冇特定格式, 分成多列 [打印本頁]

---

作者: sammyc    時間: 2011-2-18 16:34     標題: [求助] 將冇特定格式, 分成多列

如想用 vba 將gxmc欄內如有多組數字, 分成多行資料, 該如何做,

bh                            gh                                wltm            gxmc              color           csize        shul2
12195-03A        EF03500                               14939        ,1,                CH012        42        72
12195-03A        EF03622                               14930        ,2,9,                CH012        38        48
12195-03A        EF03661                               14940        ,10,2,7,4,        CH012        42        48
                                               
結果                                               
bh                            gh                                wltm            gxmc        color           csize        shul2                                               
12195-03A        EF03500                               14939        ,1,        CH012        42        72
12195-03A        EF03622                               14930        ,2,        CH012        38        48
12195-03A        EF03622                               14930        ,9,        CH012        38        48
12195-03A        EF03661                               14940        ,10,        CH012        42        48
12195-03A        EF03661                               14940        ,2,        CH012        42        48
12195-03A        EF03661                               14940        ,7,        CH012        42        48
12195-03A        EF03661                               14940        ,4,        CH012        42        48

---

作者: Hsieh    時間: 2011-2-18 16:59

回復 1# sammyc

1. Sub ex()
   
2. Dim Ar()
   
3. For Each a In Range([A1], [A65536].End(xlUp))
   
4. If InStr(a.Offset(, 3), ",") = 0 Then
   
5.    ReDim Preserve Ar(s)
   
6.    Ar(s) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value, a.Offset(, 5).Value, a.Offset(, 6).Value)
   
7.    s = s + 1
   
8.    Else
   
9.    ay = Split(a.Offset(, 3), ",")
   
10.    For Each c In ay
    
11.      If c <> "" Then
    
12.      ReDim Preserve Ar(s)
    
13.      Ar(s) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, "," & c & ",", a.Offset(, 4).Value, a.Offset(, 5).Value, a.Offset(, 6).Value)
    
14.      s = s + 1
    
15.      End If
    
16.    Next
    
17. End If
    
18. Next
    
19. [I1].Resize(s, 7) = Application.Transpose(Application.Transpose(Ar))
    
20. End Sub

複製代碼

---

作者: sammyc    時間: 2011-2-18 17:11

本帖最後由 sammyc 於 2011-2-18 17:21 編輯

回復 1# sammyc
先行謝謝, 但執行後, 沒任何變動,
行到 s = s + 1後, 己跳到next

   Ar(s) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 4).Value, a.Offset(, 5).Value, a.Offset(, 6).Value)
   s = s + 1
   Else
   ay = Split(a.Offset(, 3), ",")
   For Each c In ay
     If c <> "" Then
     ReDim Preserve Ar(s)
     Ar(s) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, "," & c & ",", a.Offset(, 4).Value, a.Offset(, 5).Value, a.Offset(, 6).Value)
     s = s + 1
     End If
   Next
End If

---

作者: Hsieh    時間: 2011-2-18 17:42

回復 3# sammyc

[attach]4777[/attach]
    [attach]4776[/attach]

---

作者: sammyc    時間: 2011-2-21 16:41

己解決, 謝謝

---

作者: GBKEE    時間: 2011-2-21 17:49

回復 1# sammyc

1. Sub Ex()
   
2. Dim Ar(), S As Integer, A As Range, I As Integer, T As String
   
3. For Each A In Range([A1], [A65536].End(xlUp))
   
4.     For I = 0 To UBound(Split(A.Cells(1, 4), ","))
   
5.         If Split(A.Cells(1, 4), ",")(I) <> "" Then
   
6.             ReDim Preserve Ar(S)
   
7.             Ar(S) = Application.Transpose(Application.Transpose(A.Resize(1, 7).Value))
   
8.             T = IIf(UBound(Split(A.Cells(1, 4), ",")) > 0, ",", "")
   
9.             Ar(S)(4) = T & Split(A.Cells(1, 4), ",")(I) & T
   
10.             S = S + 1
    
11.         End If
    
12.     Next
    
13. Next
    
14. [I1].Resize(S, 7) = Application.Transpose(Application.Transpose(Ar))
    
15. End Sub

複製代碼

---

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