適切な結果を得るためにvbaでルーピングする

Question

Excel形式の結果を適切な形式で取得しようとしていますが、ループと条件が混乱していて、一晩中ずっと試してみることができません。

簡単な構造ですが複雑なコーディング可能であれば、コードがVBscriptに対応している方が良いでしょう。

以下のコードから実際のテーブルに：予想

 E1 E2 E1 
ABC P  F 
Xyz P  P 

出力テーブルがある：

 E1 E2 
ABC P  F 
PQR F  P 
Xyz P  P 

テキストファイル：私はこれらのファイルの6

を持っています

012以下は

Env>E1 
TestName>ABC 
Result>P 

コードされる：最後に、私はそれを得た

Public Sub Temp() 
    ThisWorkbook.Sheets(1).Range("a1:D10").ClearContents 
    Dim MyObj As Object, MySource As Object, file As Variant 
    Set MyObj = CreateObject("Scripting.FileSystemObject") 
    Set MySource = MyObj.GetFolder("C:\Users\admin\Desktop\looping\xmlfile") 
    For Each file In MySource.Files 
    If InStr(file.Name, "txt") > 0 Then 
     'myFile = file.Path 
     fileSpec = file.Path '"C:\Prac_Session\OLB.xml" 'change the path to whatever yours ought to be 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objTS = objFSO.OpenTextFile(fileSpec, ForReading) 
    rowupdate = 1 
    colupdate = 1 
    Open fileSpec For Input As #1 
    Do Until EOF(1) 
     Line Input #1, textline 
      ''debug.Print textline 
       If InStr(textline, "TestName>") > 0 Then 'Read line by line and store all lines in strContents 
        For rw = 2 To 4 
         If Sheet1.Cells(rw, 1) <> Mid(textline, 10, Len(textline) - 9) Then 
          If Sheet1.Cells(rw, 1) = "" Then 
           Sheet1.Cells(rw, 1).Value = Mid(textline, 10, Len(textline) - 9) 
           rowupdate = rw 
           Exit For 
          ElseIf Sheet1.Cells(rw, 1) = Mid(textline, 10, Len(textline) - 9) Then 
           rowupdate = rw 
           Exit For 
          ElseIf Sheet1.Cells(rw, 1) <> Mid(textline, 10, Len(textline) - 9) Then 
           Sheet1.Cells(rw + 1, 1) = Mid(textline, 10, Len(textline) - 9) 
           rowupdate = rw 
           Exit For 
          End If 
         End If 
        Next 
       End If 
       If InStr(textline, "Env>") > 0 Then 'Read line by line and store all lines in strContents 
        For col = 2 To 3 
         If Sheet1.Cells(1, col) <> Mid(textline, 5, Len(textline) - 4) Then 
          If Sheet1.Cells(1, col) = "" Then 
           Sheet1.Cells(1, col).Value = Mid(textline, 5, Len(textline) - 4) 
           colupdate = col 
           Exit For 
          ElseIf Sheet1.Cells(1, col).Value = Mid(textline, 5, Len(textline) - 4) Then 
           colupdate = col 
           Exit For 
          ElseIf Sheet1.Cells(1, col) <> Mid(textline, 5, Len(textline) - 4) Then 
           Sheet1.Cells(1, col + 1) = Mid(textline, 5, Len(textline) - 4) 
           colupdate = col 
           Exit For 
          End If 
         End If 
        Next 
       End If 
       If InStr(textline, "Result>") > 0 Then 'Read line by line and store all lines in strContents 
        Sheet1.Cells(rowupdate, colupdate).Value = Mid(textline, 8, Len(textline) - 7) 
        rowupdate = 1 
        colupdate = 1 
       End If 
    Loop 
    Close #1 
    End If 
    Next file 
End Sub 

Answer 1

!!!!。これは今解決されました。ありがとう。

Public Sub Temp() 
ThisWorkbook.Sheets(1).Range("a1:D10").ClearContents 
Dim MyObj As Object, MySource As Object, file As Variant 
Set MyObj = CreateObject("Scripting.FileSystemObject") 
Set MySource = MyObj.GetFolder("C:\Users\admin\Desktop\looping\xmlfile") 
rowupdate = 2 
colupdate = 2 
For Each file In MySource.Files 
If InStr(file.Name, "txt") > 0 Then 
    'myFile = file.Path 
    fileSpec = file.Path '"C:\Prac_Session\OLB.xml" 'change the path to whatever yours ought to be 
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objTS = objFSO.OpenTextFile(fileSpec, ForReading) 

Open fileSpec For Input As #1 
Do Until EOF(1) 
    Line Input #1, textline 
     ''debug.Print textline 
    spltext = Split(textline, ">") 
    Select Case spltext(0) 
     Case "TestName" 
      Set searchtext = ThisWorkbook.Sheets(1).Range("A1:A1000").Find(spltext(1), LookIn:=xlValues) 
      If Not searchtext Is Nothing Then 
      rowspl = Split(searchtext.Address, "$") 
       lrow = rowspl(2) 'Sheet1.Cells(Rows.Count, 1).End(xlUp).Row 
       Sheet1.Cells(lrow, 1) = spltext(1) 
      Else 
       Sheet1.Cells(rowupdate, 1) = spltext(1) 
       lrow = rowupdate 
      End If 
     Case "Env" 
      Set searchtext = ThisWorkbook.Sheets(1).Range("A1:ZZ1").Find(spltext(1), LookIn:=xlValues) 
      If Not searchtext Is Nothing Then 
       colspl = Split(searchtext.Address, "$") 
       lcol = colspl(1) 'Cells(1, Columns.Count).End(xlToLeft).Column 
       Sheet1.Range(lcol & "1") = spltext(1) 
      Else 
       Sheet1.Cells(1, colupdate) = spltext(1) 
       lcol = colupdate 
      End If 
     Case "Result" 
      If lcol = "0" Or lcol = "1" Or lcol = "2" Or lcol = "3" Or lcol = "4" Then 
      Sheet1.Cells(lrow, lcol) = spltext(1) 
      rowupdate = rowupdate + 1 
      colupdate = colupdate + 1 
      Else 
      Sheet1.Range(lcol & "" & lrow).Value = spltext(1) 
      'rowupdate = rowupdate + 1 
      'colupdate = colupdate + 1 
      End If 
    End Select 
Loop 
Close #1 
End If 
Next file 
End Sub