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

標題: [發問] (字典物件)單格多行儲存格分隔為多行單格儲存格問題 [打印本頁]

作者: 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

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

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

複製代碼

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

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

作者: 葉國洲 時間: 2016-11-16 08:05

試試

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

複製代碼

作者: greetingsfromtw 時間: 2016-11-16 08:16

回復 2# 葉國洲

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

作者: Kubi 時間: 2016-11-16 09:39

回復 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 時間: 2016-11-16 12:07

回復 4# Kubi

十分感謝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

回復 6# hcm19522

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

作者: 葉國洲 時間: 2016-11-16 15:52

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

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

複製代碼

作者: greetingsfromtw 時間: 2016-11-16 16:05

回復 8# 葉國洲

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

作者: Andy2483 時間: 2023-5-15 15:15

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

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

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

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

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