麻辣家族討論版版's Archiver

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

[i=s] 本帖最後由 oobird 於 2011-10-29 11:25 編輯 [/i]

你好:

  請試試如下:[code]Sub bb()
   
    Dim mSht As Worksheet
    Dim mRng As Range, E As Range
    Dim ar, mSplit
    Dim mDic As Object
    Dim s%, s1%, s2%
   
   
    Set mDic = CreateObject("scripting.dictionary")
    Set mSht = Worksheets(1)
    With mSht
        Set mRng = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
        
        For Each E In mRng
           
            If Not mDic.Exists(E.Value) Then
                mDic(E.Value) = E.Offset(, 1).Value
            Else
               
                mDic(E.Value) = mDic(E.Value) & "," & E.Offset(, 1)
               
            End If
         
        Next
      
        s = 1
        s1 = 10
        For Each ar In mDic.Keys
            .Cells(s, s1) = ar
            mSplit = Split(mDic(ar), ",")
            For s2 = 0 To UBound(mSplit)
                .Cells(s, s1 + 1) = mSplit(s2)
                .Cells(1, s1 + 1) = "部門名稱"
                s1 = s1 + 1
            Next
            s = s + 1
            s1 = 10
        Next
        
    End With
   
End Sub[/code]

oobird 發表於 2011-10-29 11:24

[code]Sub test()
    Dim d As Object, a, b(100), m%, i%
    Set d = CreateObject("scripting.dictionary")
    a = Range([a1], [b65536].End(3))
    ReDim arr(1 To UBound(a), 1 To UBound(a))
    For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
            m = m + 1
            d(a(i, 1)) = m
            arr(m, 1) = a(i, 1): arr(m, 2) = a(i, 2): b(m) = 2
        Else
            b(m) = b(m) + 1
            arr(d(a(i, 1)), b(m)) = a(i, 2)
            x = IIf(b(m) > x, b(m), x)
        End If
    Next
    If x > 2 Then
        For i = 3 To x
            arr(1, i) = arr(1, 2)
        Next
    End If
    [d1].Resize(m, x) = arr
End Sub
[/code]

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

頁: [1]

麻辣家族討論版版為 麻辣學園 網站成員  由 昱得資訊工作室 © Since 1993 所提供