Question

我非常感谢任何帮助，因为我刚开始研究编写Excel宏。

我有excel文件，大约有1,500行，可变列长，从16-18。我想将文件的每一行写入一个新的.txt文件（实际上，我真的想把它写成.pdf，但我认为不可能），其中文件的名称是相应的第一列。另外，我希望每一行用新行分隔。因此，理想情况下，宏将1）导出每行作为新的.txt文件（或者如果可能的话.pdf），2）将每个文件命名为ColumnA，3）每个新的.txt文件的内容将包含ColumnsB-length of总列数4）每列用新行分隔。

例如，如果文档如下所示：

第1列//第2列//第3列

一个// // A1 A2

b // // B1 B2

我希望它输出为2个文件，名为“a”，“b”。例如，文件“a”的内容为：

A1

A2

我找到了另外两个堆栈溢出线程来解决我的问题的不同部分，但我不知道如何将它们拼接在一起。

每行到新的.txt文件，每列之间有一个换行符（但文件名不是ColumnA）： Create text Files from every row in an Excel spreadsheet

只有一列合并到文件中，但文件名与ColumnA对应： Outputting Excel rows to a series of text files

感谢您的帮助！

Answer 1

要将内容作为列B到文件的末尾，您可以执行以下操作。

在B列中的单元格上创建一个简单的循环。这为每行定义了一系列列，并根据A列中的值设置了文件名。

Sub LoopOverColumnB()

Dim filePath as String
Dim fileName as String
Dim rowRange as Range
Dim cell as Range

filePath = "C:\Test\" '<--- Modify this for your needs.

For each cell in Range("B1",Range("B1048576").End(xlUp))
   Set rowRange = Range(cell.address,Range(cell.address).End(xlToRight))

   fileName = filePath & cell.Offset(0,-1).Value

   '
   ' Insert code to write the text file here 
   '
   ' you will be able to use the variable "fileName" when exporting the file
Next
End Sub

Answer 2

我最终拼凑了以下内容以解决我的问题，完全归功于@David和@Exactabox。它非常低效并且具有冗余位，但它运行（非常慢）。如果有人能够发现如何清理它，请随意，但否则就可以完成任务。

[edit]不幸的是我现在意识到虽然这个宏将每一行导出为一个适当命名的新.txt文件，但每个文本文件的内容都是文档的最后一行。因此，即使它将所有20行导出为具有适当文件名和正确格式的20 .txt文件，20个文件中每个文件的实际内容也是相同的。我不确定如何纠正这个问题。

Sub SaveRowsAsTXT()

Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Dim filePath As String
Dim fileName As String
Dim rowRange As Range
Dim cell As Range

filePath = "C:\filepath\"

For Each cell In Range("B1", Range("B1048576").End(xlUp))
   Set rowRange = Range(cell.Address, Range(cell.Address).End(xlToRight))

   fileName = filePath & cell.Offset(0, -1).Value

    Set wsSource = ThisWorkbook.Worksheets("Sheet1")

    Application.DisplayAlerts = False 'will overwrite existing files without asking

    r = 1
    Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
        ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
        Set wsTemp = ThisWorkbook.Worksheets(1)

        For c = 2 To 16
            wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
        Next c

        wsTemp.Move
        Set wbNew = ActiveWorkbook
        Set wsTemp = wbNew.Worksheets(1)
        wbNew.SaveAs fileName & ".txt", xlTextWindows 'save as .txt
        wbNew.Close
        ThisWorkbook.Activate
        r = r + 1
    Loop

    Application.DisplayAlerts = True

Next
End Sub

Answer 3

这应解决在所有文件中获取相同数据的问题：

Sub SaveRowsAsTXT()

Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Dim filePath As String
Dim fileName As String
Dim rowRange As Range
Dim cell As Range

filePath = "C:\Users\Administrator\Documents\TEST\"

For Each cell In Range("B1", Range("B10").End(xlUp))
    Set rowRange = Range(cell.Address, Range(cell.Address).End(xlToRight))

    Set wsSource = ThisWorkbook.Worksheets("Sheet1")

    Application.DisplayAlerts = False 'will overwrite existing files without asking

    r = 1
    Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
        ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
        Set wsTemp = ThisWorkbook.Worksheets(1)

        For c = 2 To 16
            wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
        Next c
        fileName = filePath & wsSource.Cells(r, 1).Value

        wsTemp.Move
        Set wbNew = ActiveWorkbook
        Set wsTemp = wbNew.Worksheets(1)

        wbNew.SaveAs fileName & ".txt", xlTextWindows 'save as .txt
        wbNew.Close
        ThisWorkbook.Activate
        r = r + 1
    Loop

    Application.DisplayAlerts = True

Next
End Sub

Answer 4

@danfo，我不知道这对你是否有用，但经过一些小小的尝试，我确实得到了这个。我需要确保我的所有顶行都没有空格或特殊字符;我的左栏需要是身份证号码，而不是日期或其他任何东西 - 但是一旦我修好了这些东西，它就可以了。

将每个Excel行写入新的.text文件，并将Column作为文件名

4 个答案: