帖子: 586
主題: 123
精華: 0
積分: 763
點名: 0
作業系統: WINDOW7
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-16
最後登錄: 2017-3-14

熱烈參與勳章好學求知勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2011-11-22 15:12 | 只看該作者

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

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

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

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

樓主熱帖

字典兩各字還真難理解

oobird

　頭銜: 街友一族

超級版主 Rank: 8 Rank: 8

帖子: 1572
主題: 16
精華: 2
積分: 1521
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 150
性別: 男
註冊時間: 2010-5-1
最後登錄: 2016-1-13

論壇貢獻勳章

2^#

發表於 2011-11-22 15:56 | 只看該作者

Sub yy()
Set d = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
d(arr(i, 1)) = arr(i, 2)
Else
d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
End If
Next
c = 6
For Each k In d.keys
d(k) = Split(d(k), ",")
Cells(1, c) = k
Cells(2, c).Resize(UBound(d(k)) + 1, 1) = Application.Transpose(d(k))
c = c + 1
Next
End Sub

複製代碼

TOP

freeffly

高中生 Rank: 3 Rank: 3

帖子: 586
主題: 123
精華: 0
積分: 763
點名: 0
作業系統: WINDOW7
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-16
最後登錄: 2017-3-14

熱烈參與勳章好學求知勳章

3^#

發表於 2011-11-22 16:40 | 只看該作者

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

Sub 測試()
Application.ScreenUpdating = False
Range("F2").Resize(Range("A65536").End(xlUp).Row, Range("iv1").End(xlToLeft).Column).Clear
Columns("H:H").Clear
Range("A1:A" & Range("A65536").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"H1"), Unique:=True
Range("F1").Resize(, Range("H65536").End(xlUp).Row - 1) = Application.Transpose(Range("H2:H" & Range("H65536").End(xlUp).Row))
Range("H2:H" & Range("H65536").End(xlUp).Row).Clear
For i = 2 To Range("B65536").End(xlUp).Row
For n = 6 To [iv1].End(xlToLeft).Column
If Cells(1, n) = Cells(i, 1) Then
Cells(i, n) = Cells(i, 2)
End If
Next
Next
For n = 6 To [iv1].End(xlToLeft).Column
Columns(n).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Next
End Sub

複製代碼

字典兩各字還真難理解

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2011-11-25 09:47 | 只看該作者

回復 3# freeffly
另一寫法

Option Explicit
Sub Ex()
Dim Rng As Range, i As Integer, PastRng As Range, Ar
'Ar = Range("A1").CurrentRegion
'Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlYes
'如資料沒有排序加用上面程式碼
Set Rng = Range("A2")
Set PastRng = Range("F1")
PastRng.CurrentRegion = ""
i = 2
Do While Rng <> ""
If Rng(i) <> Rng Then
PastRng = Rng
PastRng(2).Resize(i - 1) = Range(Rng, Rng(i - 1)).Offset(, 1).Value
Set Rng = Rng(i)
Set PastRng = PastRng.Offset(, 1)
i = 2
Else
i = i + 1
End If
Loop
'Range("A1").CurrentRegion = Ar '如資料沒有排序加此程式碼
End Sub

複製代碼

TOP

freeffly

高中生 Rank: 3 Rank: 3

帖子: 586
主題: 123
精華: 0
積分: 763
點名: 0
作業系統: WINDOW7
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-16
最後登錄: 2017-3-14

熱烈參與勳章好學求知勳章

5^#

發表於 2011-11-25 17:30 | 只看該作者

回復 4# GBKEE

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

字典兩各字還真難理解

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 103
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-5-4

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

6^#

發表於 2011-11-25 20:02 | 只看該作者

回復 5# freeffly

函數解法，先將A，B欄排序

新增Microsoft Excel 工作表.zip (18.09 KB)

學海無涯_不恥下問

TOP

freeffly

高中生 Rank: 3 Rank: 3

帖子: 586
主題: 123
精華: 0
積分: 763
點名: 0
作業系統: WINDOW7
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-16
最後登錄: 2017-3-14

熱烈參與勳章好學求知勳章

7^#

發表於 2011-11-28 08:52 | 只看該作者

回復 6# Hsieh

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

字典兩各字還真難理解

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

8^#

發表於 2023-3-30 12:51 | 只看該作者

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

回復 6# Hsieh

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

執行前:

執行結果:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

9^#

發表於 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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP