올바른 결과를 얻기 위해 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 

3,516,코드입니다 :

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