寫每一行的Excel與ColumnA新的.txt文件的文件名

Question

正如我剛纔開始考慮寫Excel宏我會任何幫助非常感激。

我有大約1500的行和列的可變長度，從16-18 Excel文檔。我想將文件的每一行寫入一個新的.txt文件（實際上，我真的很想把它寫成.pdf，但我認爲這不可能），其中文件的名稱是相應的第一列。另外，我希望每行都用一個新行分隔。因此，理想情況下，宏將1）將每行導出爲新的.txt文件（如果可能，則爲.pdf），2）將每個文件命名爲ColumnA，3）每個新的.txt文件的內容將包含ColumnsB-長度總欄數4）每列由新行分隔。

例如，如果文檔看起來像這樣：

塔1 //柱2 //欄3

一個// // A1 A2

b // // B1 b2

我希望它輸出爲2個文件，名爲「a」，「b」。舉個例子，文件的內容「一」是：

A1

A2

我已經找到2個的堆棧溢出線程解決我的問題的獨立的部分，但我不知道如何將它們縫合在一起。

每一行新的.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細胞一個簡單的循環這限定的範圍內的列的每一行，並且還設置根據

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

我結束了縫合在列A中的值的文件名一起解決我的問題，完全歸功於@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 

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號碼，而不是日期或其他任何東西 - 但是一旦我解決了這些問題，它就可以正常工作。