(字典物件)單格多行儲存格分隔為多行單格儲存格問題(頁 1) - Excel程式區

greetingsfromtw 發表於 2016-11-15 21:42

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

各位前輩好,

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

[attach]25815[/attach]

將問題以文字簡述如下:

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

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

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

小弟冒昧借用論壇前輩以及網上其他朋友的程式碼進行修改,
修改之程式碼如下:[code]Sub test()
'此為參考論壇前輩及網上其他朋友所提供之程式碼進行修改,
'非我原創
'論壇網址;http://forum.twbts.com/thread-18600-1-1.html
Dim Arr, Brr(1 To 65536, 1 To 1), myD, C, UC
'關閉螢幕更新
Application.ScreenUpdating = False

Set myD = CreateObject("scripting.dictionary")
Arr = Range("a2:c" & Cells(Rows.Count, "a").End(3).Row).Value

'清除結果欄的資料
Range("e2", Cells(Rows.Count, "f")).ClearContents

For Each A In Range("b2:b" & Cells(Rows.Count, "b").End(3).Row).Value
For Each B In Split(A, Chr(10))

'將B欄多行儲存格內的值分割並代入陣列,
'使用字典物件將重複值刪除
If myD(B) = 1 Then GoTo 101
      N = N + 1
      Brr(N, 1) = B
      myD(B) = 1
101: Next B
Next A
[f2].Resize(N, 1) = Brr

'"---"虛線範圍內的程式碼在B欄多行儲存格有重複資料或空行時會出現問題
'-------------------------------------------------------

'計算B欄多行儲存格內的值的總數量並顯示於C欄
For i = 1 To UBound(Arr)
C = Split(Arr(i, 2), Chr(10))
UC = UBound(C) + 1
Arr(i, 3) = UC
Next i
[a2].Resize(UBound(Arr), 3) = Arr

'將A欄的資料依C欄的次數貼至E欄
For j = 2 To UBound(Arr) + 1
Cells(j, 1).Copy _
Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Resize(Cells(j, 3), 1)
Next j

'-------------------------------------------------------

'C欄的數字使用者用不到,故在最後清除C欄
Columns(3).ClearContents

'開啟螢幕更新
Application.ScreenUpdating = True

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

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

葉國洲 發表於 2016-11-16 08:05

試試[code]Sub test()
Dim Arr, Brr(1 To 65536, 1 To 2), C, UC
Application.ScreenUpdating = False
Arr = Range("a2:b" & Cells(Rows.Count, "a").End(3).Row).Value
Range("e2", Cells(Rows.Count, "f")).ClearContents
For Each A In Range("b2:b" & Cells(Rows.Count, "b").End(3).Row).Value
For Each b In Split(A, Chr(10))
      If Len(b) > 0 Then
      n = n + 1
      UC = UC + 1
      Brr(n, 1) = b
      End If
Next b
      m = m + 1
      Brr(m, 2) = UC
      UC = 0
Next A
[f2].Resize(n, 1) = Brr
For j = 2 To UBound(Arr) + 1
Cells(j, 1).Copy _
Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Resize(Brr(j - 1, 2), 1)
Next j
Application.ScreenUpdating = True
End Sub[/code]

greetingsfromtw 發表於 2016-11-16 08:16

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95511&ptid=18764]2#[/url] [i]葉國洲[/i] [/b]

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

Kubi 發表於 2016-11-16 09:39

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95506&ptid=18764]1#[/url] [i]greetingsfromtw[/i] [/b]
請測試
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 發表於 2016-11-16 12:07

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95515&ptid=18764]4#[/url] [i]Kubi[/i] [/b]

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

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

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

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

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

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

hcm19522 發表於 2016-11-16 14:36

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

greetingsfromtw 發表於 2016-11-16 14:45

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95523&ptid=18764]6#[/url] [i]hcm19522[/i] [/b]

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

葉國洲 發表於 2016-11-16 15:52

注釋的部分解除可實現去重[code]Sub test11()
Dim Arr, Brr(1 To 100, 1 To 2), n%, rg As Range, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Arr = Range("a2:b" & Cells(Rows.Count, "a").End(3).Row).Value
Range("e2", Cells(Rows.Count, "f")).ClearContents
Set rg = Range("b2:b" & Cells(Rows.Count, "b").End(3).Row)
For Each a In rg
For Each b In Split(a, Chr(10))
'       If Not d.exists(b) Then
'          d(b) = ""
         If Len(b) > 0 Then
         n = n + 1
         Brr(n, 1) = a.Offset(0, -1)
         Brr(n, 2) = b
         End If
'       End If
Next b
Next a
Range("f2").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Application.ScreenUpdating = True
End Sub
[/code]

greetingsfromtw 發表於 2016-11-16 16:05

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=95531&ptid=18764]8#[/url] [i]葉國洲[/i] [/b]

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

Andy2483 發表於 2023-5-15 15:15

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

執行前:
[attach]36358[/attach]

執行結果:
[attach]36359[/attach]

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

頁: [1]

麻辣家族討論版版's Archiver

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