[發問] (字典物件)單格多行儲存格分隔為多行單格儲存格問題

greetingsfromtw

各位前輩好,

小弟最近在練習時遇到一個問題,
附上檔案以供前輩參考:

20161115_(字典物件)單格多行儲存格分隔為多行單格儲存格問題.zip (9.86 KB)

下載次數: 16

2016-11-15 21:39

將問題以文字簡述如下:

假設有兩直欄資料,
A欄為一般文字,B欄的每個儲存格均有多筆資料,每筆資料有換行,

示意如下:
B欄
111
222
333
以上三筆數字均在同一個儲存格中.

希望可以將B欄的每筆資料分隔至單一儲存格,貼至F欄,
並將A欄的資料依據B欄的資料去貼上,
承上例,
假設上例之B欄對應之A欄儲存格為"AAA",
則期望結果如下:
A欄    B欄
AAA   111
AAA   222
AAA   333

小弟冒昧借用論壇前輩以及網上其他朋友的程式碼進行修改,
修改之程式碼如下:

1. Sub test()
   
2. '此為參考論壇前輩及網上其他朋友所提供之程式碼進行修改,
   
3. '非我原創
   
4. '論壇網址;http://forum.twbts.com/thread-18600-1-1.html
   
5. Dim Arr, Brr(1 To 65536, 1 To 1), myD, C, UC
   
6. '關閉螢幕更新
   
7. Application.ScreenUpdating = False
   
8. 
   
9. Set myD = CreateObject("scripting.dictionary")
   
10. Arr = Range("a2:c" & Cells(Rows.Count, "a").End(3).Row).Value
    
11. 
    
12. '清除結果欄的資料
    
13. Range("e2", Cells(Rows.Count, "f")).ClearContents
    
14. 
    
15. For Each A In Range("b2:b" & Cells(Rows.Count, "b").End(3).Row).Value
    
16.     For Each B In Split(A, Chr(10))
    
17.    
    
18.     '將B欄多行儲存格內的值分割並代入陣列,
    
19.     '使用字典物件將重複值刪除
    
20.     If myD(B) = 1 Then GoTo 101
    
21.         N = N + 1
    
22.         Brr(N, 1) = B
    
23.         myD(B) = 1
    
24. 101:    Next B
    
25. Next A
    
26. [f2].Resize(N, 1) = Brr
    
27. 
    
28. 
    
29. '"---"虛線範圍內的程式碼在B欄多行儲存格有重複資料或空行時會出現問題
    
30. '-------------------------------------------------------
    
31. 
    
32. '計算B欄多行儲存格內的值的總數量並顯示於C欄
    
33. For i = 1 To UBound(Arr)
    
34.     C = Split(Arr(i, 2), Chr(10))
    
35.     UC = UBound(C) + 1
    
36.     Arr(i, 3) = UC
    
37. Next i
    
38. [a2].Resize(UBound(Arr), 3) = Arr
    
39. 
    
40. 
    
41. 
    
42. '將A欄的資料依C欄的次數貼至E欄
    
43. For j = 2 To UBound(Arr) + 1
    
44.     Cells(j, 1).Copy _
    
45.     Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Resize(Cells(j, 3), 1)
    
46. Next j
    
47. 
    
48. '-------------------------------------------------------
    
49. 
    
50. 'C欄的數字使用者用不到,故在最後清除C欄
    
51. Columns(3).ClearContents
    
52. 
    
53. '開啟螢幕更新
    
54. Application.ScreenUpdating = True
    
55. 
    
56. End Sub

複製代碼

以上程式碼若遇到B欄資料有空行或是有重複之情形時則會出現問題,
問題情形煩請參考附檔所示.

小弟苦思許久,還是無法解決,斗膽上來求助,
還望前輩不吝指點迷津,十分感謝

葉國洲

試試

1. Sub test()
   
2. Dim Arr, Brr(1 To 65536, 1 To 2), C, UC
   
3. Application.ScreenUpdating = False
   
4. Arr = Range("a2:b" & Cells(Rows.Count, "a").End(3).Row).Value
   
5. Range("e2", Cells(Rows.Count, "f")).ClearContents
   
6. For Each A In Range("b2:b" & Cells(Rows.Count, "b").End(3).Row).Value
   
7.     For Each b In Split(A, Chr(10))
   
8.         If Len(b) > 0 Then
   
9.         n = n + 1
   
10.         UC = UC + 1
    
11.         Brr(n, 1) = b
    
12.         End If
    
13.     Next b
    
14.         m = m + 1
    
15.         Brr(m, 2) = UC
    
16.         UC = 0
    
17. Next A
    
18. [f2].Resize(n, 1) = Brr
    
19. For j = 2 To UBound(Arr) + 1
    
20.     Cells(j, 1).Copy _
    
21.     Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Resize(Brr(j - 1, 2), 1)
    
22. Next j
    
23. Application.ScreenUpdating = True
    
24. End Sub

複製代碼

greetingsfromtw

回復 2# 葉國洲

十分感謝葉國洲前輩提供解答,小弟再研究一下.

Kubi

回復 1# greetingsfromtw
請測試
Sub newtest()
    Dim Arr, Brr(), myD As Object
    Set myD = CreateObject("Scripting.Dictionary")
    Arr = Range("a2:c" & Cells(Rows.Count, "a").End(3).Row).Value
    For i = 1 To UBound(Arr)
        For j = 0 To UBound(Split(Arr(i, 2), Chr(10)))
            If Split(Arr(i, 2), Chr(10))(j) <> "" Then myD(Split(Arr(i, 2), Chr(10))(j)) = ""
        Next j
        For Each C In myD
            n = n + 1
            ReDim Preserve Brr(1 To 2, 1 To n)
            Brr(1, n) = Arr(i, 1)
            Brr(2, n) = C
        Next C
        myD.RemoveAll
    Next i
    [E2:F65536].ClearContents
    [E2].Resize(n, 2) = Application.Transpose(Brr)
End Sub

greetingsfromtw

回復 4# Kubi

十分感謝Kubi前輩無私提供解答,
跟葉國洲前輩所提供之程式碼均可有效解決問題,再次感謝.

可以的話,
是否允許小弟進一步詢問相關細節,

假設要讓B欄分割後的資料均不重覆,不知是否可行?

舉例而言,
假設現在B直欄只有兩筆資料,B2與B3,
其中B2儲存格資料為:
111
222
333,

B3儲存格資料為:
111
555
777,

因111有重複,是否有辦法將111此筆資料只顯示一次?
小弟斗膽,還請前輩不吝指點迷津,十分感謝.

hcm19522

http://blog.xuite.net/hcm19522/twblog/468529807

greetingsfromtw

回復 6# hcm19522

十分感謝hcm19522前輩以公式提供解答,小弟再研究一下.
前輩的網站小弟有加入最愛,主題能得到前輩關注,甚感榮幸.

葉國洲

注釋的部分解除可實現去重

1. Sub test11()
   
2. Dim Arr, Brr(1 To 100, 1 To 2), n%, rg As Range, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Application.ScreenUpdating = False
   
5. Arr = Range("a2:b" & Cells(Rows.Count, "a").End(3).Row).Value
   
6. Range("e2", Cells(Rows.Count, "f")).ClearContents
   
7. Set rg = Range("b2:b" & Cells(Rows.Count, "b").End(3).Row)
   
8. For Each a In rg
   
9.     For Each b In Split(a, Chr(10))
   
10. '        If Not d.exists(b) Then
    
11. '            d(b) = ""
    
12.             If Len(b) > 0 Then
    
13.             n = n + 1
    
14.             Brr(n, 1) = a.Offset(0, -1)
    
15.             Brr(n, 2) = b
    
16.             End If
    
17. '        End If
    
18.     Next b
    
19. Next a
    
20. Range("f2").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    
21. Application.ScreenUpdating = True
    
22. End Sub

複製代碼

greetingsfromtw

回復 8# 葉國洲

十分感謝葉國洲前輩費心指點,
程式碼可確實解決問題,小弟獲益良多,再次感謝.

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:

下載 (44.4 KB)

2023-5-15 15:14

執行結果:

下載 (42.91 KB)

2023-5-15 15:14

Option Explicit
Sub TEST() '↑
Dim Brr, Crr, V, Y, R&, i&
'↑ 宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是字典
Brr = Range([B2], Cells(Rows.Count, 1).End(xlUp))
'↑令Brr變數是 二維陣列,以儲存格值帶入陣列中
ReDim Crr(1 To 1000, 1 To 2)
'↑宣告 Crr變數是二維空陣列,縱向索引號1~1000,橫向索引號1~2
For i = 1 To UBound(Brr)
'↑設順迴圈!i從1到Brr縱向最大索引列號
   For Each V In Split(Brr(i, 2) & vbLf, vbLf)
   '↑設逐項迴圈!令V變數是以換行字元分割Brr陣列第2欄字串的一維陣列值之一
      If Trim(V) = "" Then GoTo v01
      '↑如果V變數去除頭尾空字元後是 空字元!就跳到v01標示位置繼續執行
      If Y(Brr(i, 1) & "|" & V) <> "" Then GoTo v01
      '↑如果Brr陣列第1欄字串連接"|",再連接V變數所組成的字串查Y字典item值,
      'item值不是空字元!就跳到v01標示位置繼續執行
      R = R + 1: Y(Brr(i, 1) & "|" & V) = 1
      '↑令R變數累加1
      '令在Y字典裡的(key:Brr陣列第1欄字串連接"|",再連接V變數所組成的字串),
      'item="" 改為 1,
      Crr(R, 1) = Brr(i, 1): Crr(R, 2) = V
      '↑令R變數列第1欄Crr陣列是 i迴圈列第1欄Brr陣列值,
      '↑令R變數列第2欄Crr陣列是 V變數
v01: Next
Next
[E2].Resize(R, 2) = Crr
'↑令[E2]擴展向下R變數列,向右擴展2欄範圍儲存格值以Crr陣列值帶入
Set Y = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub