EXCEl表中提取相同内容

将A列中相同的内容的行提取出来单独生成新的excel文件，生成的文件名为A列的内容。生成的文件最好自带表头。

 

Sub 提取相同内容()

 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)