从 Excel 数据为列中的每个不同值创建 CSV 文件？答案

【问题标题】：Create CSV file from Excel data for an each distinct value in a column?从 Excel 数据为列中的每个不同值创建 CSV 文件？
【发布时间】：2017-10-05 15:45:12
【问题描述】：

我有一个以供应商代码 (NUMBERS) 作为列之一的 Excel。

VENDORITEM|  DESCRIPTION  |PRICE|PRICEGROUP|VENDOR NUMBER|PRODUCT CATEGORY
_______________________________
HNM36789  |30ML FLUID CLIN|50.00|    B     |  023445     |CMI

TNG78934  |BACK PAD 3X5"  |32.00|    D     |  000905     |CMI

JPD12780  |FLEX DRILL GH  |9.50 |    R     |  233590     |MISC

我需要创建一个 excel vba 宏，以便我可以将每个供应商编号的数据导出到 csv 文件中，并为 csv 文件名提供类似 023445NEW 的名称，并指定一个文件夹来保存所有 csv 文件？目前，我手动执行此操作并花费大量时间。

【问题讨论】：

您是否尝试过使用 VBA 等实现自动化？
我是 VBA 新手，我只知道基本语法。但我不知道该怎么做。
参考this
链接的 vba 将范围转换为 csv。如果编辑了某些代码行，您可以使用此代码。
感谢@Dy.Lee 我已尝试使用您的代码，但我没有完全实现所需的功能。每个供应商代码仅返回一项。对于具有多个项目行的供应商代码，它似乎不正确。我什至尝试过先对文件进行排序，但没有奏效。当每个供应商代码有不止一行数据时，知道如何实现这一点吗？提前致谢

标签： vba excel

【解决方案1】：

这会将范围转换为 csv。

Sub SaveRangeToCsvFiles()
    Dim FileName As String
    Dim Ws As Worksheet
    Dim rngDB As Range
    Dim r As Long, c As Long
    Dim pathOut As String
    Dim i As Long

    pathOut = ThisWorkbook.Path & "\" ' set your path:  C:\temp\

    Set Ws = ActiveSheet 'Sheets("AllData")
    With Ws
        r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        'c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        For i = 2 To r
            Set rngDB = .Range("a" & i).Resize(1, 6)
            FileName = .Range("a" & i).Offset(, 4) & "NEW"
            TransToCSV pathOut & FileName & ".csv", rngDB
        Next i
    End With
    MsgBox ("Files Saved Successfully")
End Sub
Sub TransToCSV(myfile As String, rng As Range)

    Dim vDB, vR() As String, vTxt()
    Dim i As Long, n As Long, j As Integer
    Dim objStream
    Dim strTxt As String

    Set objStream = CreateObject("ADODB.Stream")
    vDB = rng
    For i = 1 To UBound(vDB, 1)
        n = n + 1
        ReDim vR(1 To UBound(vDB, 2))
        For j = 1 To UBound(vDB, 2)
            vR(j) = vDB(i, j)
        Next j
        ReDim Preserve vTxt(1 To n)
        vTxt(n) = Join(vR, ",")
    Next i
    strTxt = Join(vTxt, vbCrLf)
    With objStream
        '.Charset = "utf-8"
        .Open
        .WriteText strTxt
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub

【讨论】：