用ColumnA将每个Excel行写入新的.txt文件作为文件名

我将非常感谢任何帮助，因为我刚开始着手编写Excelmacros。

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

例如，如果文档看起来像这样：

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

一// // A1 A2

b // // B1 B2

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

A1

a2

我发现了另外两个堆栈溢出线程来解决我的问题，但我不知道如何将它们缝合在一起。

每行添加到新的.txt文件，并在每列之间换行（但文件名不是ColumnA）： 在Excel电子表格的每一行中创build文本文件

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

感谢您的任何帮助！

Answer 1

为了让内容成为B列到文件的结尾，你可以做这样的事情。

在列B中的单元格上创build一个简单的循环。这将为每行定义一系列的列，并根据列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。 这是非常低效，有冗余位，但它运行（非常慢）。 如果任何人都可以发现如何清理它，那么感觉自由，但否则它会完成工作。

不幸的是我现在意识到，虽然这个macros将每一行导出为一个适当命名的新的.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，我不知道这对你是否有用，但经过一番捣乱之后，我确实得到了这个工作。 我需要确保我所有的最上面一行没有空格或者特殊字符。 而我的左列需要是ID号码，而不是date或其他东西 – 但是一旦我修好了这些东西，它就可以正常工作了。