从二进制 .dat 文件中搜索特定的数据字符串，仅提取文本

Question

Sub ReadEntireFileAndPlaceOnWorksheet()
    Dim X As Long, Ys As Long, FileNum As Long, TotalFile As String, FileName As String, Result() As String, Lines() As String, rng As Range, i As Long, used As Range, lc As Long
    
         FileName = "C:\Users\MEA\Documents\ELCM2\DUMMY_FILE.dat"
        FileNum = FreeFile
         Open FileName For Binary As #FileNum
        TotalFile = Space(LOF(FileNum))
        Get #FileNum, , TotalFile
        Close #FileNum
        Lines = Split(TotalFile, vbNewLine)
         Ys = 1
         lc = Sheet3.Cells(1, Columns.Count).End(xlToLeft).Column
        For X = 1 To UBound(Lines)
            Ys = Ys + 1
            ReDim Preserve Result(1 To Ys)
            Result(Ys) = "'" & Lines(X - 1)
            Set used = Sheet1.Cells(Sheet1.Rows.Count, lc + 1).End(xlUp).Rows
            Set rng = used.Offset(1, 0)
            rng.Value = Result(Ys)
         Next
         
End Sub

我正在尝试在 .dat（二进制文件）中查找一些数据。数据应如下所示：

MiHo14.dat
MDF     3.00    TGT 15.0
Time: 06:40:29 PM
Recording Duration: 00:05:02
Database: DB
Experiment: Min Air take
Workspace: MINAIR
Devices: ETKC:1,ETKC:2
Program Description: 0delivupd2
Module_delivupd2
WP: _AWD_5
RP: _AWD
§@
Minimum intake - + revs - Downward gear ​

我目前从 .dat 文件中提取所有数据并放在 Excel 文件中的代码如下所示：

MiHo14.dat
MDF     3.00    TGT 15.0
Time: 06:40:29 PM
Recording Duration: 00:05:02
Database: DB
Experiment: Min Air take
Workspace: MINAIR
Devices: ETKC:1,ETKC:2
Program Description: 0delivupd2
Module_delivupd2
WP: _AWD_5
RP: _AWD
§@
Minimum intake - + revs - Downward gear 
Bã|ŽA…@@,s~?
B{À¿…@@@Ý‚Iá 
Á<
"@²n¢”N@ÇÿÈÿj
Ð=“SØ•N@ÇÿÈÿj   
à¨. —N@ÇÿÈÿj
 8²œg˜N@ÇÿÈÿj
0NI,¯™N@ÈÿÈÿj
Ðä$öšN@ÈÿÈÿj
@Q›=œN@ÈÿÈÿj
Пe…N@ÇÿÈÿj
 GàÍžN@ÇÿÈÿj"
etc....​

我需要知道如何使用 instr 函数通过识别包含“：”的行来提取信息，另一个挑战是数据中有最后一行是用户评论这个用户评论基本上可以是任何文本，我需要能够在不提取整个文件的情况下提取它，因为您可以看到它附带了很多符号（乱码）。

Answer 1

我认为您不想复制所有 HD/PR/TX 块来获得所需的输出。

检查您的文件，我可以看到有效数据和无效数据之间的一个区别（从您的角度来看）是无效数据不以 CR-LF 组合结尾，或者包含空字符。如果该特征在您的文件中是一致的，您可以利用它来发挥优势：

下面是我使用的代码和结果。您可以为自己的例程修改变量，看看它是否始终如一地工作。

---

Option Explicit
Sub ProcessDAT()
    Const sFN As String = "D:\Users\Ron\Desktop\DUMMY_FILE.dat"
    Const sEND As String = vbCrLf
    Dim S As String, COL As Collection, V As Variant, I As Long
    Dim R As Range

Open sFN For Binary Access Read As #1
S = Space(LOF(1))
    Get #1, , S
Close #1

V = Split(S, sEND)
Set COL = New Collection
For I = 0 To UBound(V)
    If InStr(V(I), Chr(0)) = 0 Then COL.Add V(I)
Next I

ReDim V(1 To COL.Count, 1 To 1)
For I = 1 To UBound(V)
    V(I, 1) = COL(I)
Next I

Set R = Range("a1").Resize(UBound(V))
R = V  
End Sub

---

结果

Time: 11:47:42 AM
Recording Duration: 00:01:09
Database: Testproject
Experiment: Measurement_Dummy
Workspace: Workspace
Devices: ETKC:1
Program Description: LPOOPL14
WP: LPOOPL14d2_1
RP: LPOOPL14d2
§@
Dummy test data

Answer 2

该代码无法编译，因为您没有循环您的 for 循环。

Sub ReadEntireFileAndPlaceOnWorksheet()
    Dim X As Long, Y As Long, FileNum As Long, sFile As String, FileName As String, Result() As String, Lines() As String, rng As Range, i As Long, used As Range, MyFolder As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        MyFolder = .SelectedItems(1)
    End With
    FileName = Dir(MyFolder & "\*.*")
    Do Until FileName = ""
        sFile = ReadFile(MyFolder & "\" & FileName)
        Lines = Split(sFile, vbLf)
        Y = 1
        For X = 1 To UBound(Lines)
            If InStr(1, Lines(X), ":", vbTextCompare) <> 0 Then
                ReDim Preserve Result(Y) '<-- Changed to a 1D array, I don't know why you had a 2D
                Result(Y) = "'" & Lines(X - 1)
                Y = Y + 1 '<-- increases to resize the array as it goes
            End If
        Next '<-- Added that in
        Set used = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Columns
        Set rng = used.Offset(0, 1)
        rng.Resize(UBound(Result)).Formula = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Result))
        FileName = Dir()
    Loop
End Sub


Function ReadFile(ByVal strFile As String) As String
On Error GoTo Error_Handler
    Dim FileNumber  As Integer
    Dim sFile       As String 'Variable contain file content
    FileNumber = FreeFile
    Open strFile For Binary Access Read As FileNumber
    sFile = Space(LOF(FileNumber))
    Get #FileNumber, , sFile
    Close FileNumber

    ReadFile = sFile

Error_Handler_Exit:
    On Error Resume Next
    Exit Function

Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: ReadFile" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

将数组更改为一维

最后，如果你正确缩进你的代码，它会更容易阅读和帮助你。

在此阅读文件：http://www.devhut.net/2012/05/14/vba-read-file-into-memory/

Answer 3

Option Explicit
Sub ProcessDAT()
    Const sFN As String = "C:\Users\Mohamed samatar.DSSE-EMEA\Documents\EQVL\Test\WHVP113_140827_TTinsug_TTbana_292Data_WOT_TakeOff_Launch_LaunchPlus_PUoff_REF_1.dat"
    Const sEND As String = vbCrLf
    Dim S As String, COL As Collection, V As Variant, I As Long
    Dim R As Range
    Dim MLocation  As Long
    Dim PRLocation As Long
    Dim Mstuff As String
    Dim MSize As Long
    Dim MSize1 As Integer
      
Open sFN For Binary Access Read As #1
    Get #1, &H49, MLocation

    MSize = MLocation + 2
   
    Get #1, MSize, MSize1
    'MsgBox Hex(MSize1)
    
   
    Mstuff = String$(MSize1, " ")
    Get #1, MLocation, Mstuff
Close #1

V = Split(Mstuff, sEND)
Set COL = New Collection
For I = 0 To UBound(V)
    If InStr(V(I), Chr(0)) = 0 Then COL.Add V(I)
Next I

ReDim V(1 To COL.Count, 1 To 1)
For I = 1 To UBound(V)
    V(I, 1) = COL(I)
Next I

Set R = Range("a1").Resize(UBound(V))
R = V
End Sub

我使用整数，因为它是一个 2 字节的数据类型，现在它可以工作了，如果这就是你所说的解决方案，你能评论一下吗？！