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

代码如下：

如果你是2003以上版本的Excel，那么请将上面三个地方的.xls更换成.xlsx

详细可下载附件测试，新文件在新建的以时间命名的“分类汇总”文件夹内。

Private Sub CommandButton1_Click()

    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 保存为文本()

lj = ActiveWorkbook.Path '取得路径

x1 = 1

For i = 1 To [a65536].End(xlUp).Row

If Cells(i, 1) <>Cells(i + 1, 1) Then

x2 = i

Range(Cells(x1, 1), Cells(x2, 3)).Copy

Workbooks.Add '将复制的内容放入一个新建的工作表

ActiveSheet.Paste

ActiveWorkbook.SaveAs Filename:=Cells(x1, 1), FileFormat:=xlText, CreateBackup:=False

ActiveWindow.Close (True) '关闭文件

x1 = i + 1

End If

Next

End Sub

生成的文本文件会保存在工作簿相同路径下

---