Board logo

標題: 如何透過寫程式之方式將ab欄位整合 [打印本頁]
作者: hsu.zoe    時間: 2011-10-29 00:57     標題: 如何透過寫程式之方式將ab欄位整合

請問如何將(一)之資料透過寫程式之方式轉換成(二)，A~D代表公司名稱是一樣的、1~10代表每一個不同的部門名稱。

            (一)                                                          (二)
公司名稱        部門名稱                                        公司名稱        部門名稱        部門名稱        部門名稱        部門名稱
  A        1                                                         A               1               2               3
  A        2                                                         B               4               5
  A        3                                                         C               6
B        4                           →                           D                7                8               9              10
B        5
C        6
D        7
D        8
D        9
D        10
作者: dechiuan999    時間: 2011-10-29 07:50

本帖最後由 oobird 於 2011-10-29 11:25 編輯

你好：

  請試試如下：
  1. Sub bb()
  2.    
  3.     Dim mSht As Worksheet
  4.     Dim mRng As Range, E As Range
  5.     Dim ar, mSplit
  6.     Dim mDic As Object
  7.     Dim s%, s1%, s2%
  8.    
  9.    
  10.     Set mDic = CreateObject("scripting.dictionary")
  11.     Set mSht = Worksheets(1)
  12.     With mSht
  13.         Set mRng = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
  14.         
  15.         For Each E In mRng
  16.            
  17.             If Not mDic.Exists(E.Value) Then
  18.                 mDic(E.Value) = E.Offset(, 1).Value
  19.             Else
  20.                
  21.                 mDic(E.Value) = mDic(E.Value) & "," & E.Offset(, 1)
  22.                
  23.             End If
  24.          
  25.         Next
  26.       
  27.         s = 1
  28.         s1 = 10
  29.         For Each ar In mDic.Keys
  30.             .Cells(s, s1) = ar
  31.             mSplit = Split(mDic(ar), ",")
  32.             For s2 = 0 To UBound(mSplit)
  33.                 .Cells(s, s1 + 1) = mSplit(s2)
  34.                 .Cells(1, s1 + 1) = "部門名稱"
  35.                 s1 = s1 + 1
  36.             Next
  37.             s = s + 1
  38.             s1 = 10
  39.         Next
  40.         
  41.     End With
  42.    
  43. End Sub
複製代碼
作者: oobird    時間: 2011-10-29 11:24

  1. Sub test()
  2.     Dim d As Object, a, b(100), m%, i%
  3.     Set d = CreateObject("scripting.dictionary")
  4.     a = Range([a1], [b65536].End(3))
  5.     ReDim arr(1 To UBound(a), 1 To UBound(a))
  6.     For i = 1 To UBound(a)
  7.         If Not d.exists(a(i, 1)) Then
  8.             m = m + 1
  9.             d(a(i, 1)) = m
  10.             arr(m, 1) = a(i, 1): arr(m, 2) = a(i, 2): b(m) = 2
  11.         Else
  12.             b(m) = b(m) + 1
  13.             arr(d(a(i, 1)), b(m)) = a(i, 2)
  14.             x = IIf(b(m) > x, b(m), x)
  15.         End If
  16.     Next
  17.     If x > 2 Then
  18.         For i = 3 To x
  19.             arr(1, i) = arr(1, 2)
  20.         Next
  21.     End If
  22.     [d1].Resize(m, x) = arr
  23. End Sub
複製代碼
作者: hsu.zoe    時間: 2011-10-30 00:47

多謝大大的詳解~我已經試成功嚕 ^.^
作者: Andy2483    時間: 2023-5-23 15:23

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

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

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


Option Explicit
Sub TEST()
Dim Brr, Crr, Y, i&, T$, M%
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([B1], [A65536].End(xlUp))
'↑令Brr變數是 二維陣列,以A.B欄儲存格值帶入陣列中
ReDim Crr(1 To UBound(Brr), 1 To 100)
'↑令宣告Crr變數是 二維空陣列,縱向範圍同Brr陣列,橫向索引號1~100
For i = 1 To UBound(Brr)
'↑設順迴圈!從1到Brr陣列縱向最大索引列號
   T = Brr(i, 1)
   '↑令T變數是 i迴圈第1欄Brr陣列值
   If Y(T) = "" Then
   '↑如果T變數查Y字典的item值是"" ?
      Y(T) = Y.Count
      '↑令Y字典的T變數key的item值是 Y字典key的數量
      Crr(Y(T) \ 2 + 1, 1) = T
      '↑令Crr陣列放入T變數
      Y(T & "/C") = 1
      '↑令T變數連接"/C"組成的新字串當key,item是1,納入Y字典中
   End If
   Y(T & "/C") = Y(T & "/C") + 1
   '↑令Y字典中(T變數連接"/C"組成字串)key,其item值累加1
   '這是要在Y字典中記錄T變數欄號
   Crr(Y(T) \ 2 + 1, Y(T & "/C")) = Brr(i, 2)
   '↑令Crr陣列在適當位置放入 i迴圈第2欄Brr陣列值
   If Y(T & "/C") > M Then
   '↑如果Y字典中記錄T變數欄號大於M變數
      M = Y(T & "/C")
      '↑就讓M變數換裝變數欄號
      Crr(1, M) = Brr(1, 2)
      '↑令在Crr陣列第1列M欄號位置添加一個"部門名稱"標題
   End If
Next
[E1].Resize(Y.Count \ 2 + 1, M) = Crr
'↑令Crr陣列值從[E1]開始寫入儲存格中
Set Y = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub



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