VBA提取指定区间的数据

Sub OptionalFeatureLicense()

    Dim Fs As Object, Ft As Object, S As String
    Set Fs = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("scripting.dictionary")
    filePath = ThisWorkbook.Path & "\data\"
    fileName = Dir(filePath & "*.log", vbNormal)
    Worksheets("OptionalFeatureLicense").Cells.Clear
    Worksheets("OptionalFeatureLicense").Range("A1:F1") = Array("ENBIP", "MO", "OptionalFeatureLicenseId", "featureState", "licenseState", "keyId")
   ' n = 1
    X = 0
    Do While fileName <> ""
      Set Fs = CreateObject("Scripting.FileSystemObject")
      Set Ft = Fs.opentextfile(filePath & fileName)
       Do
        texTline = Ft.ReadLinE
        If InStr(1, texTline, "MO ") > 0 And InStr(1, texTline, "OptionalFeatureLicense=") > 0 Then
          
            X = X + 1
           ' n = n + 1
            STRN = Split(Application.Trim(texTline), " ")
             Count = UBound(STRN)
             'Worksheets("SHEET1").Cells(n, 1) = fileName
             'Worksheets("SHEET1").Cells(n, X + 1) = STRN(1)
             d.Add "ENBIP", fileName
             d.Add STRN(0), STRN(1)
             
             texTline = Ft.ReadLinE
         
               Do
               
               If InStr(1, texTline, "==") > 0 Then
                 texTline = Ft.ReadLinE
                 Else:
                   
                   STRN = Split(Application.Trim(texTline), " ")
                   Count = UBound(STRN)
                   If Count >= 1 Then
                     For J = 1 To Count
                      S = S & " " & STRN(J)
                     Next
                     d.Add STRN(0), S
                     'X = X + 1
                     'Worksheets("SHEET1").Cells(n, X + 1) = S
                     S = ""
                    End If
                  texTline = Ft.ReadLinE
                End If
                
                Loop Until InStr(1, texTline, "==") > 0
          
        End If
        If d.Count > 0 Then
          'For K = 0 To d.Count - 1
           'Worksheets("SHEET1").(X+1,K) = Application.Transpose(d.keys)
          ' L1 = d.KEYS
           'L2 = d.ITEMS
           'Worksheets("sheet1").Cells(X, 1 + K) = L1(K)
           'Worksheets("sheet1").Cells(X, 1 + K) = L2(K)
           'Next
           For K = 1 To Application.CountA(Worksheets("featureState").Rows(1))
             o = Worksheets("OptionalFeatureLicense").Cells(1, K)
             L1 = d.KEYS
             L2 = d.ITEMS
             Worksheets("OptionalFeatureLicense").Cells(X + 1, K) = d(o)
           Next
         End If
        d.RemoveAll
        
        'X = 0
        'Loop Until InStr(1, texTline, ">>> Total") > 0
        Loop Until Ft.atendofstream 'Ft.atendofline 'Ft.AtEndOfLine
       Set Fs = Nothing
       Set Ft = Nothing
       Close #1
       fileName = Dir
     Loop
 MsgBox ("已完筛选、合并操作!")
End Sub