Efficiently transfer Excel formatting data to text file

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