有效地将Excel格式数据传输到文本文件
在这里，我有一个巨大的Excel工作簿，用户可以写出报价单。 在保存时，我将相关数据传输到一个文本文件并保存该文本文件，而不是保存这个庞大的工作簿。 除了一个包含格式的工作表之外，它会一帆风顺。 我不希望用户在加载先前保存的引用（来自文本文件）时丢失格式，所以我需要确定一种将格式数据传入和传出文本文件的方法。 有没有一个聪明的方法来做到这一点，而不写数百行代码或使用任何非本地Excelfunction？
以下是其他工作表的代码示例，但是对于我正在尝试执行的操作没有多大帮助：
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 这是一个使用用户types（“logging”）和随机访问IO的例子。 有限制，我相信使用随机访问可能会浪费磁盘空间，但是这是一个合理的方式去做这个。
在这个例子中，我build议使用布尔属性的位掩码，例如“粗体”（一个位掩码可以节省空间和缩短代码）。
文件读取/写入操作基于： https ： //support.microsoft.com/en-us/kb/150700
！ 你可能会得到一个“错误的logging长度”的错误 ，虽然这一切都很好，并且是第一次。 有关于这个问题的报告（谷歌VBA不良logging长度）的分配。 如果是这样的话，你可能想要将IO更改为Binary而不是Random（需要更改代码）。
!!!!! 添加一个模块并将代码粘贴到那里，或者，至less将logging粘贴到一个模块中（而不是表格）。
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
你可以尝试TextToColumns。 你正在写一个“__”的分隔符，你可以利用它。 它也似乎在接收parsing的文本时保持单元格的格式。
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