I am seeking help to write a code that will export variable ranges in each worksheet of a workbook to separate tab-delimited text files that have the same filename but are appended with the name of the worksheet they came from (e.g., \filename_03.txt, \filename_04.txt, ...). For example, I want data starting from I6 down to the last cell of data in column K. Columns I:K will be consistent, but the number of rows will not be the same for each worksheet. Column I has formulas for I6:I60000, so Range selection in code should probably select from K6 down, then over two columns to the left. I've tried writing this, but keep getting a error (see "ExportAll" code below). The range should then be exported to a tab-delimited text file. This should then be repeated for all but the last three worksheets.
Code should do the following:
-select range I6:K#, where # = number of rows from K6 thru the last occupied cell in K
-output range to text file with specified filename appended with "_" & worksheet name
-be prompted for filename and save location, ideally from same location as workbook
-repeat for each consecutive worksheet, except for last three ("all","data","summary")
-should take same filename indicated previously, just with a new appended name
I have a code that will do this process for one worksheet at a time, but is rather cumbersome for multiple worksheets. (I found these macros on the Web: http://www.cpearson.com/excel/ImpText.aspx).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ExportToTextFile
' This exports a sheet or range to a text file, using a
' user-defined separator character.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = chr(34) & chr(34)
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END ExportTextFile
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DoTheExport
' This prompts the user for the FileName and the separtor
' character and then calls the ExportToTextFile procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DoTheExport()
Dim Filename As Variant
Dim Sep As String
Filename = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
If Filename = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = vbTab
'"vbTab" outputs selection as tab-delimited'
'to choose separator, use'
'Sep = Application.InputBox("Enter a separator character.", Type:=2)'
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & Filename, "Separator: " & Sep
ExportToTextFile FName:=CStr(Filename), Sep:=CStr(Sep), _
SelectionOnly:=True, AppendData:=False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END DoTheExport
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
I've also tried using the code below to process multiple worksheets, but I get an error on Line 28
Sub ExportAll2()
'http://stackoverflow.com/questions/10551353/saving-excel-worksheet-to-csv-files-with-filenameworksheet-name-using-vb
Dim Filename As Variant
Dim Sep As String
Dim ws As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Filename = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
If Filename = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
Sep = vbTab
For Each ws In ThisWorkbook.Worksheets
ws.Range("K6", Range("K6").End(xlDown).Offset(0, -2).Address).Select
'Sheets(WS.Name).Copy
ThisWorkbook.Activate
Debug.Print "FileName: " & Filename, "Separator: " & Sep
ExportToTextFile FName:=CStr(Filename), Sep:=CStr(Sep), _
SelectionOnly:=True, AppendData:=False
Next ws
'Application.DisplayAlerts = False
'ActiveWorkbook.SaveAs FileName:=CurrentWorkbook, FileFormat:=CurrentFormat
'Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
Any suggestions on how to do this properly?
Bookmarks