excel中，用VBA編寫的，將壹列中相同的內容的行提取出來單獨生成文件

代碼如下：

如果妳是2003以上版本的Excel，那麽請將上面三個地方的.xls更換成.xlsx

詳細可下載附件測試，新文件在新建的以時間命名的“分類匯總”文件夾內。

Dim?arr

arr?=?Range("A1:C"?&?[a65536].End(3).Row)

Dim?i?As?Long,?wName?As?String,?wPath?As?String

wName?=?"分類匯總"?&?Format(Now(),?"hhmmss")

Dim?dc?As?Object,?wb?As?Workbook,?n?As?Long

Set?dc?=?CreateObject("Scripting.dictionary")

wPath?=?ThisWorkbook.Path?&?"\"?&?wName

MkDir?wPath

For?i?=?2?To?UBound(arr)

If?Not?dc.exists(arr(i,?1))?Then

Set?wb?=?Workbooks.Add

wb.SaveAs?wPath?&?"\"?&?arr(i,?1)?&?".xls"'001

wb.Sheets(1).Name?=?arr(i,?1)

'填寫表頭

wb.Sheets(1).[a1]?=?arr(1,?1)

wb.Sheets(1).[b1]?=?arr(1,?2)

wb.Sheets(1).[c1]?=?arr(1,?3)

dc.Add?arr(i,?1),?""

End?If

With?Workbooks(arr(i,?1)?&?".xls").Sheets(1)'002

n?=?.[a65536].End(3).Row?+?1

.Cells(n,?1)?=?arr(i,?1)

.Cells(n,?2)?=?arr(i,?2)

.Cells(n,?3)?=?arr(i,?3)

End?With

Next

Dim?ar

ar?=?dc.keys

For?i?=?0?To?UBound(ar)

Workbooks(ar(i)?&?".xls").Close?True'003

Next

End?Sub