Space Delimited 'Export To Text' Excel Macro Issue
I have the below vba macro to Export the selected cells into a text file. The problem seems to be the delimiter.
I need everything to be in an exact position. I have each column's width set to the correct width(9 for 9 like SSN) and I have the cells font as Courier New(9pt) in an Excel Sheet.
When I run this it comes out REALLY close to what I need but it doesn't seem to deal with the columns that are just a single space in width.
I will put the WHOLE method (and accompanying function) at the bottom for reference but first I'd like to post the portion I THINK is where I need to focus on. I just don't know in what way...
This is where I believe my issue is(delimiter is set to delimiter = "" -->
' Loop through every cell, from left to right and top to bottom.
For RowNum = 1 To TotalRows
For ColNum = 1 To TotalCols
With Selection.Cells(RowNum, ColNum)
Dim ColWidth As Integer
ColWidth = Application.RoundUp(.ColumnWidth, 0)
' Store the current cells contents to a variable.
Select Case .HorizontalAlignment
Case xlRight
CellText = Space(Abs(ColWidth - Len(.Text))) & .Text
Case xlCenter
CellText = Space(Abs(ColWidth - Len(.Text)) / 2) & .Text & _
Space(Abs(ColWidth - Len(.Text)) / 2)
Case Else
CellText = .Text & Space(Abs(ColWidth - Len(.Text)))
End Select
End With
' Write the contents to the file.
' With or without quotation marks around the cell information.
Select Case quotes
Case vbYes
CellText = Chr(34) & CellText & Chr(34) & delimiter
Case vbNo
CellText = CellText & delimiter
End Select
Print #FNum, CellText;
' Update the status bar with the progress.
Application.StatusBar = Format((((RowNum - 1) * TotalCols) _
+ ColNum) / (TotalRows * TotalCols), "0%") & " Completed."
' Loop to the next column.
Next ColNum
' Add a linefeed character at the end of each row.
If RowNum <> TotalRows Then Print #FNum, ""
' Loop to the next row.
Next RowNum
This is the WHOLE SHEBANG! For reference the original is HERE.
Sub ExportText()
'
' ExportText Macro
'
Dim delimiter As String
Dim quotes As Integer
Dim Returned As String
delimiter = ""
quotes = MsgBox("Surround Cell Information with Quotes?", vbYesNo)
' Call the WriteFile function passing the delimiter and quotes options.
Returned = WriteFile(delimiter, quotes)
' Print a message box indicating if the process was completed.
Select Case Returned
Case "Canceled"
MsgBox "The export operation was canceled."
Case "Exported"
MsgBox "The information was exported."
End Select
End Sub
'-------------------------------------------------------------------
Function WriteFile(delimiter As String, quotes As Integer) As String
' Dimension variables to be used in this function.
Dim CurFile As String
Dim SaveFileName
Dim CellText As String
Dim RowNum As Integer
Dim ColNum As Integer
Dim FNum As Integer
Dim TotalRows As Double
Dim TotalCols As Double
' Show Save As dialog box with the .TXT file name as the default.
' Test to see what kind of system this macro is being run on.
If Left(Application.OperatingSystem, 3) = "Win" Then
SaveFileName = Application.GetSaveAsFilename(CurFile, _
"Text Delimited (*.txt), *.txt", , "Text Delimited Exporter")
Else
SaveFileName = Application.GetSaveAsFilename(CurFile, _
"TEXT", , "Text Delimited Exporter")
End If
' Check to see if Cancel was clicked.
If SaveFileName = False Then
WriteFile = "Canceled"
Exit Function
End If
' Obtain the next free file number.
FNum = FreeFile()
' Open the selected file name for data output.
Open SaveFileName For Output As #FNum
' Store the total number of rows and columns to variables.
TotalRows = Selection.Rows.Count
TotalCols = Selection.Columns.Count
' Loop through every cell, from left to right and top to bottom.
For RowNum = 1 To TotalRows
For ColNum = 1 To TotalCols
With Selection.Cells(RowNum, ColNum)
Dim ColWidth As Integer
ColWidth = Application.RoundUp(.ColumnWidth, 0)
' Store the current cells contents to a variable.
Select Case .HorizontalAlignment
Case xlRight
CellText = Space(Abs(ColWidth - Len(.Text))) & .Text
Case xlCenter
CellText = Space(Abs(ColWidth - Len(.Text)) / 2) & .Text & _
Space(Abs(ColWidth - Len(.Text)) / 2)
Case Else
CellText = .Text & Space(Abs(ColWidth - Len(.Text)))
End Select
End With
' Write the contents to the file.
' With or without quotation marks around the cell information.
Select Case quotes
Case vbYes
CellText = Chr(34) & CellText & Chr(34) & delimiter
Case vbNo
CellText = CellText & delimiter
End Select
Print #FNum, CellText;
' Update the status bar with the progress.
Application.StatusBar = Format((((RowNum - 1) * TotalCols) _
+ ColNum) / (TotalRows * TotalCols), "0%") & " Completed."
' Loop to the next column.
Next ColNum
' Add a linefeed character at the end of each row.
If RowNum <> TotalRows Then Print #FNum, ""
' Loop to the next row.
Next RowNum
' Close the .prn file.
Close #FNum
' Reset the status bar.
Application.StatusBar = False
WriteFile = "Exported"
End Function
Further Discoveries
I discovered that there is something wrong with Case xlCenter below. It's Friday and I haven't been able to wrap my head around it yet but whatever it is doing in that case was removing the " ". I verified this by setting all columns to Left Justified so that the Case Else would be used instead and VIOLA! My space remained. I would like to understand why but in the end it is A) working and B) e.James's solution looks better anyway.
Thanks for the help.
Dim ColWidth As Integer
ColWidth = Application.RoundUp(.ColumnWidth, 0)
' Store the current cells contents to a variable.
Select Case .HorizontalAlignment
Case xlRight
CellText = Space(Abs(ColWidth - Len(.Text))) & .Text
Case xlCenter
CellText = Space(Abs(ColWidth - Len(.Text)) / 2) & .Text & _
Space(Abs(ColWidth - Len(.Text)) / 2)
Case Else
CellText = .Text & Space(Abs(ColWidth - Len(.Text)))
End Select
Answer
I think the problem stems from your use of the column width as the number of characters to use. When I set a column width to 1.0 in Excel, any numbers displayed in that column simply disappear, and VBA shows that the .Text property for those cells is "", which makes sense, since the .Text property gives you the exact text that is visible in Excel.
Now, you have a couple of options here:
Use the
.Valueproperty instead of the.Textproperty. The downside of this approach is that it will discard any number formatting that you have applied in the spreadsheet (I'm not sure if this is a problem in your case)Instead of using the column widths, place a row of values at the top of your spreadsheet (in row 1) to indicate the appropriate width for each column, then use those values in your VBA code instead of the column width. Then, you can make your columns a little bit wider in Excel (so that the text displays properly)
I would probably go with #2 but, of course, I don't know much about your setup, so I can't say for sure.
edit: The following workaround may do the trick. I modified your code to make use the Value and NumberFormat properties of each cell, instead of using the .Text property. This should take care of the problems with one-character wide cells.
With Selection.Cells(RowNum, ColNum)
Dim ColWidth As Integer
ColWidth = Application.RoundUp(.ColumnWidth, 0)
'// Store the current cells contents to a variable.'
If (.NumberFormat = "General") Then
CellText = .Text
Else
CellText = Application.WorksheetFunction.Text(.NumberFormat, .value)
End If
Select Case .HorizontalAlignment
Case xlRight
CellText = Space(Abs(ColWidth - Len(CellText))) & CellText
Case xlCenter
CellText = Space(Abs(ColWidth - Len(CellText)) / 2) & CellText & _
Space(Abs(ColWidth - Len(CellText)) / 2)
Case Else
CellText = CellText & Space(Abs(ColWidth - Len(CellText)))
End Select
End With
update: to take care of the centering problem, I would do the following:
Case xlCenter
CellText = Space(Abs(ColWidth - Len(CellText)) / 2) & CellText
CellText = CellText & Space(ColWidth - len(CellText))
This way, the padding on the right side of the text will automatically cover the remaining space.