[發問] (已解決)如何列出相同部門的員工

freeffly

想將A欄跟B欄的資料處理成像F欄跟G欄那樣
第一格是部門第二格之後的是該部門員工
依序將A欄跟B欄的資料處理完




新增Microsoft Excel 工作表.rar (4.26 KB)

下載次數: 34

2011-11-22 15:09

oobird

1. Sub yy()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         If Not d.exists(arr(i, 1)) Then
   
6.             d(arr(i, 1)) = arr(i, 2)
   
7.         Else
   
8.             d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
   
9.         End If
   
10.     Next
    
11.     c = 6
    
12.     For Each k In d.keys
    
13.         d(k) = Split(d(k), ",")
    
14.         Cells(1, c) = k
    
15.         Cells(2, c).Resize(UBound(d(k)) + 1, 1) = Application.Transpose(d(k))
    
16.         c = c + 1
    
17.     Next
    
18. End Sub

複製代碼

freeffly

回復 2# oobird
謝謝版主回覆
下面是我剛想出來的方式
方法差真多
而且我的方式可以說是有點蠟擦(掉漆)
版主又使用了我不太會的字典
先收下研究
感恩

1. Sub 測試()
   
2.     Application.ScreenUpdating = False
   
3.     Range("F2").Resize(Range("A65536").End(xlUp).Row, Range("iv1").End(xlToLeft).Column).Clear
   
4.     Columns("H:H").Clear
   
5.     Range("A1:A" & Range("A65536").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
   
6.         "H1"), Unique:=True
   
7.     Range("F1").Resize(, Range("H65536").End(xlUp).Row - 1) = Application.Transpose(Range("H2:H" & Range("H65536").End(xlUp).Row))
   
8.     Range("H2:H" & Range("H65536").End(xlUp).Row).Clear
   
9.     For i = 2 To Range("B65536").End(xlUp).Row
   
10.     For n = 6 To [iv1].End(xlToLeft).Column
    
11.     If Cells(1, n) = Cells(i, 1) Then
    
12.         Cells(i, n) = Cells(i, 2)
    
13.     End If
    
14.     Next
    
15.     Next
    
16.     For n = 6 To [iv1].End(xlToLeft).Column
    
17.     Columns(n).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    
18.     Next
    
19. End Sub

複製代碼

GBKEE

回復 3# freeffly
另一寫法

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, i As Integer, PastRng As Range, Ar
   
4.     'Ar = Range("A1").CurrentRegion
   
5.     'Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlYes
   
6.     '如資料沒有排序加用上面程式碼
   
7.     Set Rng = Range("A2")
   
8.     Set PastRng = Range("F1")
   
9.     PastRng.CurrentRegion = ""
   
10.     i = 2
    
11.     Do While Rng <> ""
    
12.         If Rng(i) <> Rng Then
    
13.             PastRng = Rng
    
14.             PastRng(2).Resize(i - 1) = Range(Rng, Rng(i - 1)).Offset(, 1).Value
    
15.             Set Rng = Rng(i)
    
16.             Set PastRng = PastRng.Offset(, 1)
    
17.             i = 2
    
18.         Else
    
19.             i = i + 1
    
20.         End If
    
21.     Loop
    
22.    'Range("A1").CurrentRegion = Ar    '如資料沒有排序加此程式碼
    
23. End Sub

複製代碼

freeffly

回復 4# GBKEE


    謝謝版主
   此方法一樣可以腦筋有點快打結了
   收下研究

Hsieh

回復 5# freeffly

函數解法，先將A，B欄排序
新增Microsoft Excel 工作表.zip (18.09 KB)

下載次數: 17

2011-11-25 20:01

freeffly

回復 6# Hsieh


    謝謝版主提供函數寫法
   又多一種學習方式

Andy2483

回復 6# Hsieh


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

執行前:

下載 (150.88 KB)

2023-3-30 12:49

執行結果:

下載 (209.47 KB)

2023-3-30 12:49

Option Explicit
Sub TEST()
Dim Brr, Crr, i&, xR, Y
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, 1).End(3)): Brr = xR
For i = 1 To UBound(Brr)
   If Y(Brr(i, 1)) = "" Then Y(Brr(i, 1)) = Y.Count
Next
With [K1].Resize(, Y.Count)
   .EntireColumn.ClearContents
   .Value = Y.keys
End With
ReDim Crr(UBound(Brr), 1 To Y.Count)
For i = 1 To UBound(Brr)
   Crr(Y(Brr(i, 1) & "|"), Y(Brr(i, 1))) = Brr(i, 2)
   Y(Brr(i, 1) & "|") = Y(Brr(i, 1) & "|") + 1
Next
[K2].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習字典中的陣列編輯,請各位前輩指教

Option Explicit
Sub TEST_2()
Dim Brr, Crr, i&, R&, xR, Y, Z, V, N
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B2], Cells(Rows.Count, 1).End(3)): Brr = xR
R = UBound(Brr): ReDim A(1 To R, 0)
For i = 1 To R
   If Not IsArray(Brr(i, 1)) Then Y(Brr(i, 1)) = A
Next
With [K1].Resize(, Y.Count)
   .EntireColumn.ClearContents: .Value = Y.keys
End With
For i = 1 To R
   Z = Y(Brr(i, 1)): Y(Brr(i, 1) & "|") = Y(Brr(i, 1) & "|") + 1
   Z(Y(Brr(i, 1) & "|"), 0) = Brr(i, 2): Y(Brr(i, 1)) = Z
Next
For Each V In Y.Items
   If IsArray(V) Then N = N + 1: [K2].Item(1, N).Resize(R, 1) = V
Next
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub