麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] VBA內把", " 轉為換欄 [打印本頁]

作者: kan109 時間: 2018-8-31 01:10 標題: VBA內把", " 轉為換欄

Sub test()
Dim dic As Object, data, i%
Set dic = CreateObject("scripting.dictionary")
data = Range(Cells(1, 1), Cells(1, 2).End(4))
For i = 1 To UBound(data)
If Not dic.exists(data(i, 1)) Then
dic.Add data(i, 1), data(i, 2)
Else
If InStr(dic(data(i, 1)), data(i, 2)) = 0 Then
dic(data(i, 1)) = dic(data(i, 1)) & " , " & data(i, 2)
End If
End If
Next
Cells(1, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
Cells(1, 4).Resize(dic.Count, 1) = Application.Transpose(dic.items)
Columns(4).TextToColumns Destination:=Cells(1, 4), OtherChar:=" , "
Cells.Columns.AutoFit
Set dic = Nothing
End Sub

複製代碼

以上此代碼,如何把結果得來是以每個欄代替" , "
[attach]29302[/attach]
以現時得出結果,十分混亂
謝謝幫忙

作者: kan109 時間: 2018-8-31 01:13

另外,請問如何可以把以上VBA 用在mac excel 上?

作者: n7822123 時間: 2018-8-31 02:38

本帖最後由 n7822123 於 2018-8-31 02:52 編輯

回復 1# kan109

沒有檔案沒法幫你改，大概說一下，
用split可以把長字串依","分開成陣列
範例擋如下，可以把第一欄依逗點分開成陣列，再從第2欄開始填

[attach]29305[/attach]

Sub AA()
Dim bb() As String
For i = 1 To Cells(Rows.Count, 1).End(3).Row
bb = Split(Cells(i, 1), ",")
Cells(i, 2).Resize(1, UBound(bb) + 1) = bb
Next i
End Sub

複製代碼

作者: kan109 時間: 2018-8-31 10:35

已上載,,謝謝

作者: kan109 時間: 2018-8-31 12:50

回復 4# n7822123

已試過,但好像跟我想的不一樣.謝謝幫忙

作者: n7822123 時間: 2018-8-31 13:47

本帖最後由 n7822123 於 2018-8-31 14:02 編輯

回復 6# kan109

請你清楚敘述一下你要的目的，不然誰也無法幫你

如果你所說的"得來的結果" 是第4欄的話，試試下面這串程式
把第4欄依","分欄，從第5欄填上

Sub ddd()
Dim bb() As String
For i = 1 To Cells(Rows.Count, 4).End(3).Row
bb = Split(Cells(i, 4), ",")
Cells(i, 5).Resize(1, UBound(bb) + 1) = bb
Next i
End Sub

複製代碼

如果你想要別人幫你改程式，請清楚說明那串程式的目的

作者: n7822123 時間: 2018-8-31 23:39

本帖最後由 n7822123 於 2018-8-31 23:51 編輯

回復 7# n7822123

總算看懂你要的了，看看這個是否符合你的需求

假設第一欄是標題，第二欄是內容，

第三欄放不重複的標題，第4欄往後放同樣標題的內容(內容用欄做分格)

應該是這樣吧!?

全程序修改如下!

[attach]29312[/attach]

Sub test()
Dim dic As Object, data, i%, AA$
Dim bb() As String
Set dic = CreateObject("scripting.dictionary")
data = Range(Cells(1, 1), Cells(1, 2).End(4))
For i = 1 To UBound(data)
AA = data(i, 1)
If Not dic.exists(AA) Then
dic(AA) = data(i, 2)
Else
If InStr(dic(AA), data(i, 2)) = 0 Then
dic(AA) = dic(AA) & "," & data(i, 2)
End If
End If
Next
Cells(1, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
For i = 1 To dic.Count
AA = data(i, 1)
bb = Split(dic(AA), ",")
Cells(i, 4).Resize(1, UBound(bb) + 1) = bb
Next i
Set dic = Nothing
End Sub

複製代碼

作者: n7822123 時間: 2018-9-1 00:19

回復 8# n7822123

上一篇有點小錯，修改如下

[attach]29313[/attach]

Sub test()
Dim dic As Object, data, i%, AA$
Dim bb() As String

Set dic = CreateObject("scripting.dictionary")
data = Range(Cells(1, 1), Cells(1, 2).End(4))
For i = 1 To UBound(data)
  AA = data(i, 1)
  If Not dic.exists(AA) Then
   dic(AA) = data(i, 2)
  Else
If InStr(dic(AA), data(i, 2)) = 0 Then
   dic(AA) = dic(AA) & "," & data(i, 2)
End If
  End If
Next
Cells(1, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
On Error Resume Next
For i = 1 To dic.Count
  AA = Cells(i, 3).Value
  bb = Split(dic(AA), ",")
  Cells(i, 4).Resize(1, UBound(bb) + 1) = bb
Next i
Set dic = Nothing
End Sub

作者: kan109 時間: 2018-9-1 00:56

回復 n7822123

上一篇有點小錯，修改如下

Sub test()
Dim dic As Object, data, i%, AA ...
n7822123 發表於 2018-9-1 00:19

超感謝~~

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