Übernahme des Inhalts von IFC-Dateien in Excel Tabelle

[sunny01]

Hallo Andre,

kannst Du mir bitte doch den gesamten Code mit den Ergänzungen nochmals angeben?

[sunny01]

Hallo Andre,

ich habe den bisherigen Code getestet und festgestellt, das dieser bereits den ersten Eintrag von Kategorie übernimmt (ohne Deinen zusätzlichen Code von zuletzt)!? Das habe ich getestet, indem ich in einer zweiten Tabelle lediglich die Einträge von IFCPROPERTYSINGLEVALUE eingelesen habe.

[schauan]

Hallöchen,
ob das so ist oder nur so aussieht ... In einigen Fällen war es ja so, dass der erste und zweite Eintrag gleich waren.

Hier nochmal der komplette Code. Die -1 bei den 3 Einträgen für strSearch7 hab ich wieder rausgenommen entsprechend Deiner Antwort #49

Code:

Sub IFC()

Dim strLine$, strCutter$
  Dim strSearch1$, strSearch2$, strSearch3$, strSearch4$, strSearch5$, strSearch6$
  Dim arrText(3), arrTemp
  Dim lStart&
  Dim boMerker As Boolean
  lStart = 1
  strSearch1 = "IFCBUILDINGSTOREY"
  strSearch2 = "IFCLOCALPLACEMENT"
  strSearch3 = "IFCRECTANGLEPROFILEDEF"
  strSearch4 = "IFCEXTRUDEDAREASOLID"
  strSearch5 = "IFCSPACE"
  strSearch6 = "IFCQUANTITYAREA"
  strSearch7 = "IFCPROPERTYSINGLEVALUE"
  
  Open Datei_Dialog For Input As #1
  Do While Not EOF(1)
     Line Input #1, strLine
    
     If InStr(strLine, strSearch1) > 0 Or _
        InStr(strLine, strSearch2) > 0 Or _
        InStr(strLine, strSearch3) > 0 Or _
        InStr(strLine, strSearch4) > 0 Or _
        InStr(strLine, strSearch5) > 0 Or _
        InStr(strLine, strSearch6) > 0 Or _
        InStr(strLine, strSearch7) > 0 Then
        
        strLine = Left(strLine, Len(strLine) - 2)
        strReplace strLine
        strCutter = "="
        arrTemp = Split(strLine, strCutter)
        arrText(0) = arrTemp(0)
        strCutter = "("
        arrTemp = Split(arrTemp(1), strCutter)
        arrText(1) = Trim(arrTemp(0))
        arrText(2) = arrTemp(1)
        If Right(arrText(2), 8) = "IFCLABEL" And UBound(arrTemp) > 1 Then
          arrText(2) = arrText(2) & "(" & arrTemp(2)
        End If
        strCutter = ","
        Select Case arrText(1)
          Case strSearch1
            Cells(lStart, 1) = arrText(1)
            Cells(lStart, 2) = Split(arrText(2), strCutter)(2)
            Cells(lStart, 3) = Split(arrText(2), strCutter)(5)
            Cells(lStart, 4) = Split(arrText(2), strCutter)(9)
            lStart = lStart + 1
          Case strSearch2
            Cells(lStart, 2) = Split(arrText(2), strCutter)(0)
          Case strSearch3
            Cells(lStart, 7) = Split(arrText(2), strCutter)(3)
            Cells(lStart, 8) = Split(arrText(2), strCutter)(4)
          Case strSearch4
            Cells(lStart, 6) = Split(arrText(2), strCutter)(3)
          Case strSearch5
            Cells(lStart, 1) = Split(arrText(2), strCutter)(0)
            Cells(lStart, 3) = Split(arrText(2), strCutter)(2)
            Cells(lStart, 4) = Split(arrText(2), strCutter)(7)
          Case strSearch6
            Cells(lStart, 5) = Split(arrText(2), strCutter)(3)
            lStart = lStart + 1
            boMerker = False
          Case strSearch7
             If InStr(1, arrText(2), "IFCLABEL") > 0 And InStr(1, arrText(2), "Kategorie") > 0 And Not boMerker Then
               boMerker = True
               Cells(lStart, 9) = "IFCLABEL"
               Cells(lStart, 10) = "Kategorie"
               Cells(lStart, 11) = Replace(Replace(Split(arrText(2), strCutter)(2), "IFCLABEL(", ""), "'", "")
             End If
          End Select
          Range(Cells(lStart, 1), Cells(lStart, 9)).Replace What:=".", Replacement:="."
     End If
  Loop
  Close #1
End Sub

[sunny01]

Hallo Andre,

vielen Dank für Deinen neuen Code. Der neue Code liest bei mir die Kategorien teilweise falsch aus, Dein voriger Code war eigentlich immer korrekt und hat zuletzt immer den nächstfolgenden Wert von Kategorie ausgelesen. Ich denke mir, ich werde den Code von vorher beibehalten.

[schauan]

Hallo Sunny,

da ist bei mir eventuell bei den einzelnen Änderungen was untergegangen. Aber wenn's mit dem "Vorletzten" Code klappt ist ja alles gut