2

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

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

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

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

一个//a1//a2

b//b1//b2

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

a1

a2

我发现另外 2 个堆栈溢出线程解决了我的问题的各个部分，但我不知道如何将它们拼接在一起。

每一行到新的 .txt 文件，每列之间有一个换行符（但文件名不是 ColumnA）： 从 Excel 电子表格中的每一行创建文本文件

只有一列合并到文件中，但文件名与 ColumnA 对应： 将 Excel 行输出到一系列文本文件

感谢您的任何帮助！

4

4 回答 4

4

要使内容成为文件末尾的 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
于 2013-03-21T18:10:01.640 回答
1

我最终将以下内容拼接在一起来解决我的问题，这完全感谢@David 和@Exactabox。它效率极低并且有冗余位，但它运行（非常。缓慢）。如果有人知道如何清理它，请随意，否则它可以完成工作。

[编辑] 不幸的是，我现在意识到虽然这个宏将每一行导出为一个适当命名的新 .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
于 2013-03-27T17:43:54.050 回答
1

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

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
于 2014-01-02T22:02:22.207 回答
0

@danfo，我不知道这对您是否有用，但经过一番摆弄，我确实做到了。我需要确保我所有的顶行都没有空格或特殊字符；我的左栏需要是 ID 号，而不是日期或其他任何东西——但一旦我修复了这些东西，它就可以正常工作了。

于 2016-11-01T14:25:43.273 回答