Board logo

標題: [發問] (已解決)如何列出相同部門的員工 [打印本頁]
作者: freeffly    時間: 2011-11-22 15:12     標題: (已解決)如何列出相同部門的員工

本帖最後由 freeffly 於 2012-2-22 16:53 編輯

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




[attach]8599[/attach]
作者: oobird    時間: 2011-11-22 15:56

  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    時間: 2011-11-22 16:40

回復 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    時間: 2011-11-25 09:47

回復 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    時間: 2011-11-25 17:30

回復 4# GBKEE


    謝謝版主
   此方法一樣可以腦筋有點快打結了
   收下研究
作者: Hsieh    時間: 2011-11-25 20:02

回復 5# freeffly

函數解法，先將A，B欄排序
[attach]8629[/attach]
作者: freeffly    時間: 2011-11-28 08:52

回復 6# Hsieh


    謝謝版主提供函數寫法
   又多一種學習方式
作者: Andy2483    時間: 2023-3-30 12:51

本帖最後由 Andy2483 於 2023-3-30 12:59 編輯

回復 6# Hsieh


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

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

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


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    時間: 2023-3-30 13:51

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

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



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