CKellerSID
New Member
- Joined
- Jan 22, 2015
- Messages
- 8
I am using the code from this page: Exporting And Importing Text Into Excel to export an Excel worksheet to a certain format so I can import into another program.
I found the other program can only import 50 lines at at time (not counting the first and second line). So I want to export the excel worksheet into different text files breaking with the count of the rows =50 and save them with a "2", "3" etc at the end of the file names. Also each file must start with the same first and second lines which I have saved in the code as FirstLine and SecondLine
I did some editing on the code that I found and this is what I am currently using. The part I need help with is enclosed by '========================= lines
Thank you.
I found the other program can only import 50 lines at at time (not counting the first and second line). So I want to export the excel worksheet into different text files breaking with the count of the rows =50 and save them with a "2", "3" etc at the end of the file names. Also each file must start with the same first and second lines which I have saved in the code as FirstLine and SecondLine
I did some editing on the code that I found and this is what I am currently using. The part I need help with is enclosed by '========================= lines
Thank you.
Code:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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)
'from http://www.cpearson.com/excel/ImpText.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Requirements:
'ask user for directory to store the files.
' Export data enclosed by double quotes and separated by commas.
' The first line and second lines do not need to be enclosed by double quotes but must be separated by commas
' The first line and second lines do not need a comma at the end.
'save file as .txt file
'the text files can only contain 50 lines
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
Dim dirName As String
Dim NumEnd As String
Dim FirstLine As String
Dim SecondLine As String
Quote = Chr(34)
comma = Chr(44)
Sep = Chr(34) & Chr(44)
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 there is nothing in cell then put nothing in cellvalue
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
'the first row doesn't need a comma at the end
If RowNdx = 1 Then
If Cells(RowNdx, ColNdx).Value = "" Then
WholeLine = WholeLine
Else
WholeLine = WholeLine & CellValue
End If
End If
'the second row doesn't need comma or quote at the end
If RowNdx = 2 Then
If Cells(RowNdx, ColNdx).Value = "" Then
WholeLine = WholeLine
Else
If ColNdx = EndCol Then
WholeLine = WholeLine & CellValue
Else
WholeLine = WholeLine & CellValue & comma
End If
End If
End If
If RowNdx > 2 Then
If ColNdx = EndCol Then
WholeLine = WholeLine & Quote & CellValue & Quote
Else
WholeLine = WholeLine & Quote & CellValue & Sep
End If
End If
Next ColNdx
If RowNdx = 1 Then
WholeLine = WholeLine
'the first and second line must repeat in all of the text files at the beginning
FirstLine = WholeLine
End If
If RowNdx = 2 Then
WholeLine = Trim(WholeLine)
LastInLine = Right(WholeLine, Len(WholeLine) - 1)
If LastInLine = "," Then
WholeLine = Left(WholeLine, Len(WholeLine) - 1) ' remove the end comma
Else
WholeLine = WholeLine
End If
'the first and second line must repeat in all of the text files at the beginning
SecondLine = WholeLine
End If
If RowNdx > 2 Then
' WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
If LastInLine = "," Then
WholeLine = Left(WholeLine, Len(WholeLine) - 1) ' remove the end comma
Else
WholeLine = WholeLine
End If
End If
If RowNdx Mod 50 = 0 Then
Print #FNum, WholeLine ' want the last line to go into the file that is completing
'=================================================
'start a new file - this is what I don't know how to do.
'=================================================
'make sure the file starts with First and second lines
' Print #FNum, FirstLine
' Print #FNum, SecondLine
'then have the 51-60 go into the second file, the 101-150 go into a third file, etc.
Else
Print #FNum, WholeLine
End If 'for If RowNdx Mod 50 = 0
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
statusbox = MsgBox("Export Completed", vbInformation)
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
Dim FolderDate As Date
'FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
With Application.FileDialog(msoFileDialogFolderPicker)
'
.AllowMultiSelect = False
If .Show <> -1 Then
MsgBox ("No Folder Selected. Exiting out...")
Exit Sub
End If
dirName = .SelectedItems(1)
End With
FileName = dirName & "\" & ActiveSheet.Name & "_" & Format(Date, "mmddyyy") & ".txt"
'If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
'Exit Sub
'End If
'Sep = Application.InputBox("Enter a separator character.", Type:=2)
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
'Exit Sub
Sep = ""
End If
Debug.Print "FileName: " & FileName, "Separator: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END DoTheExport
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''