【VBA】VBA编写的，将一列中相同的内容的行提取出来单独生成文件

 

数据如上图所示，点击RUN后的运行结果如下：

 

得到该文件夹，文件夹内容如上图。

代码如下：

Private Sub Command_OLIVER()
    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

调用该sub

Sub 调用()
 Command_OLIVER
End Sub

注意：必须在同一模块中call该sub，因为上述sub为私有的，局部方法.

附件下载

 

作者：奔跑的金鱼