Efficiently transfer Excel formatting data to text file - vba

Question

Here it is, I have a huge Excel workbook with which users write pricing quotes. On save, rather than saving the huge workbook, I'm transferring the relevant data to a text file and saving that text file. It's going off without a hitch, except for the one worksheet that contains formatting. I don't want the user to lose formatting when they load the previously saved quote (from the text file), so I need to determine a way to transfer that formatting data to and from the text file. Is there a smart way to do this without writing hundreds of lines of code or using any non-native Excel feature?
Here's a sample of the code for other sheets, but it's not much help for what I'm trying to do:
Sub WriteQuote()
Dim SourceFile As String
Dim data As String
Dim ToFile As Integer
Dim sh1, sh2, sh3 As Worksheet
Set sh1 = Sheets("sheet 1")
Set sh2 = Sheets("sheet 2")
Set sh3 = Sheets("sheet 3")
SourceFile = "C:\Users\███████\Desktop\test.txt"
ToFile = FreeFile
Open SourceFile For Output As #ToFile
'PRINT DETAILS TO TXT FILE
For i = 7 To 56
If sh1.Range("B" & i).Value <> "" Then
data = sh1.Range("B" & i).Value & "__"
If sh1.Range("D" & i).Value <> "" Then
data = data & sh1.Range("D" & i).Value & "__"
Else: data = data & " __"
End If
If sh1.Range("E" & i).Value <> "" Then
data = data & "ns" & "__"
Else: data = data & " __"
End If
data = data & sh1.Range("F" & i).Value & "__"
data = data & sh1.Range("G" & i).Value & "__"
data = data & sh1.Range("J" & i).Value & "__"
data = data & sh1.Range("M" & i).Value
Else: Exit For
End If
Print #ToFile, data
Next i
Close #ToFile
End Sub

Answer 1

This is an example using a user type ("record") and Random access IO.
There are limitations, and I believe using Random access
would probably waste space on disk, however it is a reasonable
way to go about doing this.
In the example I suggest using a bit mask for boolean properties,
for example "Bold" (a bit mask can save space and shorten the code).
The file read/write actions are based on :
https://support.microsoft.com/en-us/kb/150700
!!! It is possible that you'll get a "bad record length" error, although
every this is fine and works the first time. There are allot of reports about this issue (google VBA bad record length). If that is the case, you might want to change the IO to Binary instead of Random (code change will be needed).
!!!!! Add a module and paste the code there, or, for the very least,
paste the record in a module (not in a sheet).
Option Explicit
' Setting up a user type ("record").
' you can add more variables, however just makes sure they are fixed
' length, for example: integer\doube\byte\... Note that if you want to
' add a string, ' make sure to give it fixed length, as shown below.
Public Type OneCellRec
' this will hold the row of the source cell
lRow As Long
' this will hold the column of the source cell
lColumn As Long
' This will hold the value of the cell.
' 12 is the maximum length you expect a cell to have-
' CHANGE it as you see fit
Value As String * 12
' This hold the number format- again, you might need to
' twik the 21 length-
NumberFormat As String * 21
' will hold design values like Bold, Italic and so on
DesignBitMask1 As Integer
' will hold whether the cells has an underline- this is not boolean,
' as there are several type of underlines available.
UnderLine As Long
FontSize As Double
End Type
' ---- RUN THIS ---
Public Sub TestFullTransferUsingRec()
Dim cellSetUp As Range
Dim cellSrc As Range
Dim cellDst As Range
Dim r As OneCellRec
Dim r2 As OneCellRec
On Error Resume Next
Kill "c:\file1.txt"
On Error GoTo 0
On Error GoTo errHandle
' For the example,
' Entering a value with some design values into a cell in the sheet.
' --------------------------------------
Set cellSetUp = ActiveSheet.Range("A1")
cellSetUp.Value = 1.5
cellSetUp.Font.Bold = True
cellSetUp.Font.Size = 15
cellSetUp.Font.UnderLine = xlUnderlineStyleSingle
cellSetUp.NumberFormat = "$#,##0.00"
' Doing it again for example purposes, in a different cell.
Set cellSetUp = ActiveSheet.Range("C5")
cellSetUp.Value = "banana"
cellSetUp.Font.Bold = True
cellSetUp.Font.Size = 15
cellSetUp.Font.UnderLine = XlUnderlineStyle.xlUnderlineStyleDouble
' ============ saving the cells to the text file =============
' open file for write
Open "c:\file1.txt" For Random As #1 Len = Len(r)
' save to a record the value and the design of the cell
Set cellSrc = ActiveSheet.Range("A1")
r = MyEncode(cellSrc)
Put #1, , r
' save to a record the value and the design of the cell
Set cellSrc = ActiveSheet.Range("C5")
r = MyEncode(cellSrc)
Put #1, , r
Close #1
' ============ loading the cells from the text file =============
Application.EnableEvents = False
' open file for read
Dim i%
Open "c:\file1.txt" For Random As #1 Len = Len(r2)
' read the file
For i = 1 To Int(LOF(1) / Len(r))
Get #1, i, r2
' destination cell- write the value and design
' --------------------------------------------
Set cellDst = Sheet2.Cells(r2.lRow, r2.lColumn)
Call MyDecode(cellDst, r2)
Next
'Close the file.
Close #1
errHandle:
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Number & " " & _
Err.Description, vbExclamation, "Error"
On Error Resume Next
Close #1
On Error GoTo 0
End If
Application.EnableEvents = True
End Sub
' Gets a single cell- extracts the info you want into a record.
Public Function MyEncode(cell As Range) As OneCellRec
Dim r As OneCellRec
Dim i%
i = 0
r.lRow = cell.row
r.lColumn = cell.column
r.Value = cell.Value
r.FontSize = cell.Font.Size
r.UnderLine = cell.Font.UnderLine
r.NumberFormat = cell.NumberFormat
' Use a bit mask to encode true\false excel properties.
' the encode is done using "Or"
If cell.Font.Bold = True Then i = i Or 1
If cell.Font.Italic = True Then i = i Or 2
'If cell. ..... .. = True Then i = i Or 4
'If cell. ..... .. = True Then i = i Or 8
'If cell. ..... .. = True Then i = i Or 16
'If cell. ..... .. = True Then i = i Or 32
'If cell. ..... .. = True Then i = i Or 64
'If cell. ..... .. = True Then i = i Or 128
'If cell. ..... .. = True Then i = i Or 256
' Remember the Integer limit. If you want more than int can handle,
' use long type for the i variable and r.DesignBitMask1 variable.
'If cell. ..... .. = True Then i = i Or ' (2^x)-
r.DesignBitMask1 = i
MyEncode = r
End Function
' Decode- write the info from a rec to a destination cell
Public Sub MyDecode(cell As Range, _
r As OneCellRec)
Dim i%
cell.Value = r.Value
i = r.DesignBitMask1
cell.Value = Trim(r.Value)
cell.Font.Size = r.FontSize
cell.Font.UnderLine = r.UnderLine
' trim is important here
cell.NumberFormat = Trim(r.NumberFormat)
' Use a bit mask to decode true\false excel properties.
' the decode is done using "And"
If i And 1 Then cell.Font.Bold = True
If i And 2 Then cell.Font.Italic = True
'If i And 4 Then ...
'If i And 8 Then ...
'...
End Sub

Answer 2

You could try TextToColumns. You're writing a delimiter in "__" that you could take advantage of. It also seems to keep the formatting of the cells when receiving the parsed text.
Sub ReadQuote()
SourceFile = "C:\Users\||||||\Desktop\test.txt"
Open SourceFile For Input As #8
Input #8, data
Range("M1") = data 'Temporary holder for an input line
'Range to start the parsed data "A1" in this example
Range("A1") = Range("M1").TextToColumns(, xlDelimited, , , , , , , , "__")
Close #8
End Sub