返回列表 上一主題 發帖

[求助] 將冇特定格式, 分成多列

[求助] 將冇特定格式, 分成多列

如想用 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
50 字節以內
不支持自定義 Discuz! 代碼

回復 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
複製代碼
學海無涯_不恥下問

TOP

本帖最後由 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
50 字節以內
不支持自定義 Discuz! 代碼

TOP

回復 3# sammyc

未命名.png
2011-2-18 17:42

   
未命名.png
2011-2-18 17:41
學海無涯_不恥下問

TOP

己解決, 謝謝
50 字節以內
不支持自定義 Discuz! 代碼

TOP

回復 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
複製代碼

TOP

        靜思自在 : 人要知福、惜福、再造福。
返回列表 上一主題