Übernahme des Inhalts von IFC-Dateien in Excel Tabelle

[sunny01]

Hallo Andre,

ich habe unten den zuletzt einwandfrei funktionierenden Code für 6 Elemente (ohne IFCPROPERTYSINGLEVALUE) eingefügt. Bitte versuche selbst die zum Auslesen von den Werten in Klammer von IFCPROPERTYSINGLEVALUE benötigten Code zu ergänzen. Wichtig wäre, dass in erster Linie immer der Wert "Kategorie" und der Wert in Klammer (wenn die Werte in eigenen Zellen gefügt sind) ebenfalls in dieselbe Zeile von IFCSPACE geschrieben werden, wie die anderen Werte (das hat bis jetzt mit den Ergänzungen leider nicht funktioniert).

Nochmals der Auszug aus dem IFC Code: #939= IFCPROPERTYSINGLEVALUE('Kategorie',$,IFCLABEL('Lagerung'),$);

Code:

Sub IFC()

Dim strLine$, strCutter$
 Dim strSearch1$, strSearch2$, strSearch3$, strSearch4$, strSearch5$, strSearch6$
 Dim arrText(3), arrTemp
 Dim lStart&
 lStart = 1
 strSearch1 = "IFCBUILDINGSTOREY"
 strSearch2 = "IFCLOCALPLACEMENT"
 strSearch3 = "IFCRECTANGLEPROFILEDEF"
 strSearch4 = "IFCEXTRUDEDAREASOLID"
 strSearch5 = "IFCSPACE"
 strSearch6 = "IFCQUANTITYAREA"
 
 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 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)
       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                                
         End Select
         Range(Cells(lStart, 1), Cells(lStart, 9)).Replace What:=".", Replacement:="."
    End If
 Loop
 Close #1
 
End Sub

[schauan]

Hallöchen,

bei 6 Elementen bekomme ich das

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D	E	F	G	H
1	IFCBUILDINGSTOREY	Ebene 0'	#118	0
2	2_sC7Er$z02AV0XKhZTKrd'	#118	1'	K\X2\00DC\X0\CHE'	25	2,75	5	5
3		$

Diese Tabelle wurde mit Tab2Html (v2.5.0) erstellt. ©Gerd alias Bamberg

und bei 7 das

Arbeitsblatt mit dem Namen 'Tabelle3'
	A	B	C	D	E	F	G	H	I	J
1	IFCBUILDINGSTOREY	Ebene 0'	#118	0
2	2_sC7Er$z02AV0XKhZTKrd'	#118	1'	K\X2\00DC\X0\CHE'	25	2,75	5	5	IFCLABEL	Symbol
3		$

Diese Tabelle wurde mit Tab2Html (v2.5.0) erstellt. ©Gerd alias Bamberg

Der Code zu den 7 ist der:

Code:

Sub IFC()

Dim strLine$, strCutter$
  Dim strSearch1$, strSearch2$, strSearch3$, strSearch4$, strSearch5$, strSearch6$
  Dim arrText(3), arrTemp
  Dim lStart&
  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
          Case strSearch7
             If InStr(1, arrText(2), "IFCLABEL") > 0 Then
               Cells(lStart - 1, 9) = "IFCLABEL"
               Cells(lStart - 1, 10) = Replace(Replace(Split(arrText(2), strCutter)(0), "IFCLABEL(", ""), "'", "")
             End If
          End Select
          Range(Cells(lStart, 1), Cells(lStart, 9)).Replace What:=".", Replacement:="."
     End If
  Loop
  Close #1
  
End Sub

[sunny01]

Hallo,

vielen Dank für Den Code. Ich habe diesen in folgendem Bereich ein wenig angepasst:

Code:

Case strSearch7
            If InStr(1, arrText(2), "IFCLABEL") > 0 Then
              'Cells(lStart - 1, 9) = "IFCLABEL"
              Cells(lStart, 9) = Replace(Replace(Split(arrText(2), strCutter)(0), "IFCLABEL(", ""), "'", "")
              Cells(lStart, 10) = Replace(Replace(Split(arrText(2), strCutter)(2), "IFCLABEL(", ""), "'", "")
            End If

 Dadurch und mithilfe Deines Codes bekomme ich (beinahe) die Art der Auflistung wie gewünscht, bei mir sieht das so aus (ich weiß leider nicht, wie ein Screenshot eingefügt werden kann):

IFCBUILDINGSTOREY              Ebene -1'     #133       -3,25
2umIVmbhj1XQ7vZJsZzU1c'     #133            1'            LAGER 1'      28,03     3,00     5,75     4,88    Ebene    Ebene -1)

Der Eintrag von Ebene  und Ebene -1 müsste nun nur noch ersetzt werden durch den Eintrag der "Kategorie" in einer anderen  Zeile von IFCPROPERTYSINGLEVALUE. 
Auszüge aus dem IFC Code:
derzeit im Code ausgegeben: #219= IFCPROPERTYSINGLEVALUE('Ebene',$,IFCLABEL('Ebene -1'),$);
optimal wäre: #215= IFCPROPERTYSINGLEVALUE('Kategorie',$,IFCLABEL('Lagerung'),$);

Vielleicht kannst Du den Code noch in diese Richtung anpassen.

[schauan]

Hallo,

kann man dann das Wort "Kategorie" fest programmieren?

[sunny01]

Hallo,

der Wert in der inneren Klammer wäre wichtig, da dieser die Kategoriebezeichnung ist. Der Wert sollte bei jedem Raum vorhanden sein. Vielleicht kann man im Code nach der Bezeichnung Kategorie im Bereich bis zum nächsten Raumwert suchen und den Wert dann in die Zeile mit den anderen Einträgen übertragen.

[schauan]

Hallo Sunny,

was ist denn der Raumwert?

[sunny01]

Hallo,

mit Raumwert meinte ich die Zeile von IFCSPACE, in der der nächstfolgende Raum angegeben ist. Zwischen den jeweils beiden Einträgen befindet sich ein Eintrag zu "Kategorie", welcher sich auf den oberen Raum bezieht. Vielleicht wäre das bzw. meine Beschreibung von vorher ein Ansatz, diesen Wert per Code noch zu ergänzen.

[schauan]

Hallo,


dann diese Zeile
If InStr(1, arrText(2), "IFCLABEL") > 0 Then
so erweitern
If InStr(1, arrText(2), "IFCLABEL") > 0 And InStr(1, arrText(2), "Kategorie") > 0 Then

In der nächsten Codezeile wird ja IFCLABEL eingetragen. Wenn das passt, dann ist ok.
Wenn nicht, kannst Du dort IFCLABEL durch Kategorie ersetzen. Wenn Kategorie daneben soll, fügst Du das einfach darunter ein und nimmst den nächsten Ausdruck eine Spalte weiter nach rechts. Der Wert in Klammern müsste der 2. Index sein, dort steht noch eine 0.

[sunny01]

Hallo Andre,

vielen Dank, jetzt funktioniert das Einlesen der Kategorie! Ich habe den Eintrag am Anfang nur so abgeändert: 

Cells(lStart, 9) = .....,  Cells(lStart, 10) = .....

Dadurch werden die Zellen in dieselbe Zeile wie die anderen Einträge geschrieben. Mir ist nur aufgefallen, dass teilweise öfters Kategorie unter einem Raumeintrag steht. Da wäre es gut, dass immer nur der erste Eintrag von Kategorie unterhalb dem zugehörigen Raum eingelesen wird. Ist das derzeit bei dem Code bereits der Fall?

[schauan]

Hallo sunny,

nein, es ist der jeweils letzte.
da müsste man so ca. 4 Zeilen ändern oder hinzufügen. Das Makro muss sich merken, dass es im jeweiligen Bereich schon einen Treffer hatte und den "Merker" nach dem Wechsel in den nächsten Bereich zurücksetzten. Ich schreib jetzt mal nur die notwendigen Änderungen, bei Bedarf kann ich auch nochmal den ganzen Code einstellen.

1. oben bei den Dim's noch ein
Dim boMerker As boolean
2. wo wir gestern das If mit der Kategorie erweitert haben kommt eine weitere Bedingung dazu
... And Not boMerker ...
3. und darunter
boMerker = True
4. wo der Zeilenzähler hochgesetzt wird - unter Case strSearch6 - noch eine Zeile
boMerker = False