Dim?Arr,?Rng?As?Range,?Sht?As?Worksheet,?Dic?As?Object
Dim?k,?t,?Str?As?String,?i?As?Long,?lc?As?Long
Application.ScreenUpdating?=?False?'關閉屏幕更新
Arr?=?Range("A1").CurrentRegion.Value
lc?=?UBound(Arr,?2)?'求取最後壹列的列號
Set?Rng?=?Rows(1)?'標題行
Set?Dic?=?CreateObject("Scripting.Dictionary")?'創建字典
For?i?=?2?To?UBound(Arr)
Str?=?Arr(i,?3)?'承攬人姓名，關鍵字
If?Not?Dic.Exists(Str)?Then?'如果字典沒有關鍵字
Set?Dic(Str)?=?Cells(i,?1).Resize(,?lc)?'把當前行裝入到字典中
Else?'否則(字典中存在關鍵字)
Set?Dic(Str)?=?Union(Dic(Str),?Cells(i,?1).Resize(,?lc))?'把行連合起來
End?If
Next
k?=?Dic.Keys?'字典關鍵字集合
t?=?Dic.Items?'字典項目集合
On?Error?Resume?Next
With?Sheets
For?i?=?0?To?Dic.Count?-?1?'循環關鍵字的個數
Set?Sht?=?.Item(k(i))?'給變量賦值(工作表名為關鍵字)
If?Sht?Is?Nothing?Then?'該工作表不存在則插入壹個空工作表
.Add(After:=.Item(.Count)).Name?=?k(i)?'新建的工作表將置於所有工作表之後，並命名為關鍵字
Set?Sht?=?ActiveSheet?'活動工作表給變量
Else?'否則
Sht.Cells.Clear?'清除工作中所有內容和格式
End?If
Rng.Copy?Sht.Range("A1")?'把標題寫入第壹行
t(i).Copy?Sht.Range("A2")?'寫入其他內容
Sht.Cells.EntireColumn.AutoFit?'自動調整全工作表單元格的列寬
Set?Sht?=?Nothing?'變量處於初始狀態
Next
End?With
Sheets(1).Activate?'第1個工作表處於激活狀態
Application.ScreenUpdating?=?True?'打開屏幕更新
End?Sub
假如承攬人姓名在C列