Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
save row as text
' this script was posted at
'and is presented here for readers of the Historian's Macroscope
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
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
wbNew.SaveAs fileName & ".txt", xlTextWindows 'save as .txt
r = r + 1
Application.DisplayAlerts = True
End Sub

panfeng commented Jul 6, 2015

you can rename this file as xxx.vb so the syntax highlighting will work.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment