[發問] VBA內把", " 轉為換欄

kan109

1. Sub test()
   
2. Dim dic As Object, data, i%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     data = Range(Cells(1, 1), Cells(1, 2).End(4))
   
5.     For i = 1 To UBound(data)
   
6.         If Not dic.exists(data(i, 1)) Then
   
7.             dic.Add data(i, 1), data(i, 2)
   
8.         Else
   
9.         If InStr(dic(data(i, 1)), data(i, 2)) = 0 Then
   
10.             dic(data(i, 1)) = dic(data(i, 1)) & " , " & data(i, 2)
    
11.         End If
    
12.         End If
    
13.     Next
    
14.     Cells(1, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
15.     Cells(1, 4).Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
16.     Columns(4).TextToColumns Destination:=Cells(1, 4), OtherChar:=" , "
    
17.    Cells.Columns.AutoFit
    
18.     Set dic = Nothing
    
19. End Sub

複製代碼

以上此代碼,如何把結果得來是以每個欄代替" , "

下載 (581.79 KB)

2018-8-31 01:06

以現時得出結果,十分混亂
謝謝幫忙

kan109

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

kan109

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

n7822123

回復 1# kan109


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

aaa.rar (7.41 KB)

下載次數: 3

2018-8-31 02:52

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

複製代碼

kan109

已上載,,謝謝

kan109

回復 4# n7822123

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

n7822123

回復 6# kan109


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

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

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

複製代碼

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

n7822123

回復 7# n7822123

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

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

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

應該是這樣吧!?

全程序修改如下!

sample_001-0831.rar (289.56 KB)

下載次數: 2

2018-8-31 23:50

1. Sub test()
   
2. Dim dic As Object, data, i%, AA$
   
3. Dim bb() As String
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. data = Range(Cells(1, 1), Cells(1, 2).End(4))  
   
6. For i = 1 To UBound(data)
   
7.   AA = data(i, 1)
   
8.   If Not dic.exists(AA) Then
   
9.       dic(AA) = data(i, 2)
   
10.   Else
    
11.     If InStr(dic(AA), data(i, 2)) = 0 Then
    
12.       dic(AA) = dic(AA) & "," & data(i, 2)
    
13.     End If
    
14.   End If
    
15. Next
    
16. Cells(1, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
17. For i = 1 To dic.Count
    
18.   AA = data(i, 1)
    
19.   bb = Split(dic(AA), ",")
    
20.   Cells(i, 4).Resize(1, UBound(bb) + 1) = bb
    
21. Next i
    
22. Set dic = Nothing
    
23. End Sub

複製代碼

n7822123

回復 8# n7822123


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

sample_001-0831+.rar (277.19 KB)

下載次數: 4

2018-9-1 00:18

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

回復  n7822123


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



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

    超感謝~~