Übernahme des Inhalts von IFC-Dateien in Excel Tabelle

[schauan]

Hallo Sunny,

das Eintragen nebeneinander funktioniert so:

Sub IFC_Einlesen()

'Variablendeklaration 

'String 

Dim strLine$, strCutter$, arrText, strSearch1$, strSearch2$

'Integer 

Dim iCol%

'Long 

Dim lStart&

'Dateneintrag ab Zeile 1 

lStart = 1

'Suchwort, ggf. per Inputbox 

strSearch1 = "IFCQUANTITYAREA"

strSearch2 = "IFCSPACE"

'Datei Oeffnen mit Dialog 

Open Datei_Dialog For Input As #1

'Schleife bis Dateiende 

Do While Not EOF(1)

 'Zeile einlesen 

 Line Input #1, strLine

 'nur importieren wenn strSearch vorhanden 

 'ggf. Großschreibung verarbeiten 

 If InStr(strLine, strSearch1) > 0 Or InStr(strLine, strSearch2) > 0 Then

   'Klammer und Semikolon am Ende abtrennen 

   strLine = Left(strLine, Len(strLine) - 2)

   'Umlaute ersetzen 

   strReplace strLine

   'Trennzeichen = 

   strCutter = "="

   'Zeilennummer abtrennen 

   arrText = Split(strLine, strCutter)

   'Zeilennummer in Spalte A = 1 eintragen 

   Cells(lStart, 1) = arrText(0)

   'Trennzeichen ( 

   strCutter = "("

   'Suchwort abtrennen 

   arrText = Split(arrText(1), strCutter)

   'Suchwort in Spalte B = 2 eintragen 

   Cells(lStart, 2) = Trim(arrText(0))

   'zu uebernehmende "Spalte" je nach Suchwort festlegen 

   'bea: Array faengt mit Index 0 an 

   If Trim(arrText(0)) = strSearch1 Then iCol = 3 Else iCol = 7

   'Trennzeichen , 

   strCutter = ","

   'Resttext aufteilen 

   arrText = Split(arrText(1), strCutter)

   'Resttext in Spalte C eintragen 

   With Cells(lStart, 3 + Abs(1 * (InStr(strLine, strSearch2) = 0)))

     'Resttext eintragen 

     .Value = arrText(iCol)

     'Punkt durch Komma ersetzen 

     'Hinweis: wegen englischem VBA Punkt durch Punkt  

     .Replace What:=".", Replacement:="."

   'Ende Mit dem Bereich ab Spalte C 

   End With

   'Zeile 1 erhöhen 

   If InStr(strLine, strSearch1) > 0 Then lStart = lStart + 1

 'Ende nur importieren wenn strSearch vorhanden 

 End If

'Ende Schleife bis Dateiende 

Loop

'Datei schließen. 

Close #1

End Sub

Ich habe dazu folgende Änderungen eingebracht:
Hier habe ich die Spaltenberechnung eingefügt:
With Cells(lStart, 3 + Abs(InStr(strLine, strSearch2) = 0))

Die Zeilennummer erhöhe ich nur noch, wenn der Suchstring strSearch1 vorkommt:
If InStr(strLine, strSearch1) > 0 Then lStart = lStart + 1

Ich hab den zwar als 1 definiert, aber im ifc ist das der zweite und damit letzte von den beiden.


Wenn Du nun noch mehr Klassen importieren willst, musst Du die Suchstrings entsprechend erweitern.

Das beginnt mit
Dim strSearch3$

setzt sich fort mit
strSearch3 = "irgendwas"

geht weiter mit
If InStr(strLine, strSearch1) > 0 Or InStr(strLine, strSearch2) > 0 Or InStr(strLine, strSearch3) > 0 Then

muss auch hier rein, allerdings etwas anders
alt
With Cells(lStart, 3 + Abs((InStr(strLine, strSearch2) = 0)))
neu (ungetestet)
With Cells(lStart, 3 + Abs(1 * (InStr(strLine, strSearch1) > 0)) + Abs(2 * (InStr(strLine, strSearch1) > 0)))

und wenn der Suchstring strSearch1 nicht mehr der letzte ist, sondern z.B. der strSearch3, muss es auch hier geändert werden
If InStr(strLine, strSearch3) > 0 Then lStart = lStart + 1

Das Ganze funktioniert aber nur, wenn alle Suchstrings pro Bereich jeweils maximal ein mal kommen und der für den Zeilenwechsel verantwortliche dabei der letzte im Bereich ist.

[sunny01]

Hallo Andre,

ich habe den Code versucht anzupassen, ist mir leider nicht geglückt (nachfolgend findest Du den Code). Ideal wäre es wenn die 4 Klassennamen, die abgefragt werden, jeweils in Zeile 1 nebeneinander stehen (sind derzeit untereinander angeführt) und darunter alle zusammenhängenden Einträge pro Raum nebeneinander: zuerst Geschoss ("IFCBUILDINGSTOREY" - entspricht Spalte E), dann Raumbezeichnung ("IFCSPACE" - entspricht Spalte J), dann Fläche ("IFCQUANTITYAREA" - entspricht Spalte F), dann Höhe ("IFCSURFACEOFLINEAREXTRUSION" - entspricht Spalte F)

Code:

Sub IFC_Einlesen_Tabellen()
'Variablendeklaration
'String
Dim strLine$, strCutter$, arrText, strSearch1$, strSearch2$, strSearch3$, strSearch4$
'Integer
Dim iCol%
'Long
Dim lStart&
'Dateneintrag ab Zeile 1
lStart = 1
'Suchwort, ggf. per Inputbox
strSearch1 = "IFCBUILDINGSTOREY"
strSearch2 = "IFCSPACE"
strSearch3 = "IFCQUANTITYAREA"
strSearch4 = "IFCSURFACEOFLINEAREXTRUSION"
'Datei Oeffnen mit Dialog
Open Datei_Dialog For Input As #1
'Schleife bis Dateiende
Do While Not EOF(1)
 'Zeile einlesen
 Line Input #1, strLine
 'nur importieren wenn strSearch vorhanden
 'ggf. Großschreibung verarbeiten
 If InStr(strLine, strSearch1) > 0 Or InStr(strLine, strSearch2) > 0 Or InStr(strLine, strSearch3) > 0 Or InStr(strLine, strSearch4) > 0 Then
   'Klammer und Semikolon am Ende abtrennen
   strLine = Left(strLine, Len(strLine) - 2)
   'Umlaute ersetzen
   strReplace strLine
   'Trennzeichen =
   strCutter = "="
   'Zeilennummer abtrennen
   arrText = Split(strLine, strCutter)
   'Zeilennummer in Spalte A = 1 eintragen
   Cells(lStart, 1) = arrText(0)
   'Trennzeichen (
   strCutter = "("
   'Suchwort abtrennen
   arrText = Split(arrText(1), strCutter)
   'Suchwort in Spalte B = 2 eintragen
   Cells(lStart, 2) = Trim(arrText(0))
   'zu uebernehmende "Spalte" je nach Suchwort festlegen
   'bea: Array faengt mit Index 0 an
   If Trim(arrText(0)) = strSearch1 Then iCol = 3 Else iCol = 7
   'Trennzeichen ,
   strCutter = ","
   'Resttext aufteilen
   arrText = Split(arrText(1), strCutter)
   'Resttext in Spalte C eintragen
   With Cells(lStart, 3 + Abs(1 * (InStr(strLine, strSearch1) > 0)) + Abs(2 * (InStr(strLine, strSearch1) > 0)))
     'Resttext eintragen
     .Value = arrText(iCol)
     'Punkt durch Komma ersetzen
     'Hinweis: wegen englischem VBA Punkt durch Punkt :-)
     .Replace What:=".", Replacement:="."
   'Ende Mit dem Bereich ab Spalte C
   End With
   'Zeile 1 erhöhen
   If InStr(strLine, strSearch3) > 0 Then lStart = lStart + 1
 'Ende nur importieren wenn strSearch vorhanden
 End If
'Ende Schleife bis Dateiende
Loop
'Datei schließen.
Close #1

End Sub

[schauan]

Hallöchen,

da hast Du nun zwei Klassen hinzugefügt, die nicht in den Rhythmus der Daten passen.
IFCBUILDINGSTOREY kommt nur am Anfang 3x, dann nicht nochmal
IFCSURFACEOFLINEAREXTRUSION kommt gar nicht vor.

Untereinander würde das wie unten aussehen. Ich kann da nun schlecht IFCBUILDINGSTOREY irgendwo neben IFCSPACE oder IFCQUANTITYAREA packen. Das müssen eigene, einzelne Zeilen werden.
Oder da gibt es irgendeine andere Regel, wie die zusammenzufügen sind. Die müsstest Du mal aufstellen. Wenn es da unterschiedliche Klassen gibt, die unterschiedlich zu behandeln sind, müssten alle betreffenden definiert werden. Wie gesagt, die ...EXTRUSION ist im Beispiel nicht vorhanden, die könnte ja auch eine eigene Behandlungsmethode erfordern.


#115= IFCBUILDINGSTOREY('3NURL7gSr1SR5bJQc5_roL',#41,'Ebene 1 Grundriss-EG',$,$,#113,$,'Ebene 1 Grundriss-EG',.ELEMENT.,-0.0001465);
#121= IFCBUILDINGSTOREY('3NURL7gSr1SR5bJQc5_roK',#41,'Ebene 2 Grundriss-OG',$,$,#120,$,'Ebene 2 Grundriss-OG',.ELEMENT.,3.1275509);
#127= IFCBUILDINGSTOREY('3NURL7gSr1SR5bJQc5_roJ',#41,'TOP LEVEL',$,$,#126,$,'TOP LEVEL',.ELEMENT.,9.2235509);
#255= IFCSPACE('2qqGIV1MfE4RwYcZc8lXrP',#41,'1','',$,#130,#251,'Flur',.ELEMENT.,.INTERNAL.,$);
#260= IFCQUANTITYAREA('GSA Space Areas',$,$,14.2170438585902);
#379= IFCSPACE('2qqGIV1MfE4RwYcZc8lXrR',#41,'2','',$,#355,#377,'Bad mit Dusche',.ELEMENT.,.INTERNAL.,$);
#382= IFCQUANTITYAREA('GSA Space Areas',$,$,5.02129680545398);
#471= IFCSPACE('2qqGIV1MfE4RwYcZc8lXrT',#41,'3','',$,#458,#469,'Hauswirtschaftsraum',.ELEMENT.,.INTERNAL.,$);
#474= IFCQUANTITYAREA('GSA Space Areas',$,$,7.60447033469788);
#562= IFCSPACE('2qqGIV1MfE4RwYcZc8lXrV',#41,'4','',$,#549,#560,'K\X2\00FC\X0\che',.ELEMENT.,.INTERNAL.,$);
#565= IFCQUANTITYAREA('GSA Space Areas',$,$,14.2338890745239);
#782= IFCSPACE('2qqGIV1MfE4RwYcZc8lXlj',#41,'6','',$,#642,#780,'Wohnzimmer',.ELEMENT.,.INTERNAL.,$);
#785= IFCQUANTITYAREA('GSA Space Areas',$,$,44.94352192892);
#992= IFCSPACE('2qqGIV1MfE4RwYcZc8lXip',#41,'10','',$,#865,#990,'Flur',.ELEMENT.,.INTERNAL.,$);
#995= IFCQUANTITYAREA('GSA Space Areas',$,$,19.0667929096906);
#1142= IFCSPACE('2qqGIV1MfE4RwYcZc8lXiW',#41,'11','',$,#1070,#1140,'Ankleide',.ELEMENT.,.INTERNAL.,$);
#1145= IFCQUANTITYAREA('GSA Space Areas',$,$,4.69707252372521);
#1337= IFCSPACE('2qqGIV1MfE4RwYcZc8lXiY',#41,'12','',$,#1220,#1335,'Bad mit Wanne und Dusche',.ELEMENT.,.INTERNAL.,$);
#1340= IFCQUANTITYAREA('GSA Space Areas',$,$,14.2944556576251);
#1496= IFCSPACE('2qqGIV1MfE4RwYcZc8lXia',#41,'13','',$,#1415,#1494,'Schlafzimmer',.ELEMENT.,.INTERNAL.,$);
#1499= IFCQUANTITYAREA('GSA Space Areas',$,$,13.7721080201893);
#1646= IFCSPACE('2qqGIV1MfE4RwYcZc8lXic',#41,'14','',$,#1574,#1644,'B\X2\00FC\X0\ro',.ELEMENT.,.INTERNAL.,$);
#1649= IFCQUANTITYAREA('GSA Space Areas',$,$,16.8338953624107);
#1814= IFCSPACE('2qqGIV1MfE4RwYcZc8lXjO',#41,'15','',$,#1724,#1812,'Kinderzimmer',.ELEMENT.,.INTERNAL.,$);
#1817= IFCQUANTITYAREA('GSA Space Areas',$,$,15.5995793791001);

[sunny01]

Hallo Andre,

ich habe inzwischen die Klassen durchforstet und habe den nachfolgenden Code angepasst. Nun wäre noch wichtig, die wiederkehrenden Zelleinträge mit der gewünschten Information in eine Zeile zu setzen (wie du es bereits für 2 Einträge gemacht hast). Wenn du den Code unten anhand der in diesem Beitrag beiliegenden Datei ausführst, siehst Du die Einträge von einem Raum.

Ausgehend von IFC SPACE ist eine Zeile darüber immer  IFCEXTRUDEDAREASOLID,  zwei Zeilen darüber IFCRECTANGLEPROFILEDEF und drei Zeilen darüber  IFCLOCALPLACEMENT sowie eine Zeile darunter IFCQUANTITYAREA. Das immer in demselben Rhythmus (bei weiteren Räumen). Nun würde ich Dich bitten folgende relevante Zelleinträge in diesen Zeilen jeweils in eine Zeile schreiben zu lassen (mit Schleife für weitere Räume): 

Zelle A = Zelle A von IFCSPACE, 
Zelle B = Zelle B von IFCSPACE, 
Zelle C = Zelle C von IFCLOCALPLACEMENT, 
Zelle D = Zelle J von IFCSPACE, 
Zelle E = Zelle F von IFCQUANTITYAREA, 
Zelle F = Zelle F von IFCEXTRUDEDAREASOLID, 
Zelle G = Zelle F von IFCRECTANGLEPROFILEDEF, 
Zelle H = Zelle G von IFCRECTANGLEPROFILEDEF

Code mit den 6 Klassen:

Code:

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

[schauan]

Hallöchen,

das könnte in etwa so gehen. Ich hab da jetzt für die 6 Fälle nit Select Case 6 Fallunterscheidungen eingebracht. Du müsstest allerdings die "Spalten" anpassen.
zum Beispiel:
Cells(lStart, 4) = Split(arrText(2), strCutter)(9)
Die 9 wäre Spalte J. Das hängt damit zusammen, dass das Array mit 0 beginnt, also ist die 9 das 10. Element. Irgendwie passt das aber mit den Spalten nicht so richtig.
Bei diesen Daten
#1340= IFCQUANTITYAREA('GSA Space Areas',$,$,14.2944556576251);
würde ich den 4. Wert übernehmen. Das wäre dann aus dem Array der Index ...(3)
Spalte E wäre 5, da soll es bestimmt hin. Spalte F passt aber gar nicht, denn F wäre ja 6 und nicht 4 bzw. 3 ...

Den Zeilenvorschub mache ich nach dem letzten Eintrag eines Blockes, also bei Auftreten von IFCQUANTITYAREA sowie bei IFCBUILDINGSTOREY

Die Einträge mach ich jetzt ohne Schleife, lässt sich dann eventuell einfacher variieren und erweitern. Kommentare hab ich weggelassen, die vorhandenen hast Du ja im Code rausgenommen

Sub IFC_Einlesen_6werte()

  

  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, 1) = Split(arrText(2), strCutter)(4)

            lStart = lStart + 1

          Case strSearch2

            Cells(lStart, 3) = Split(arrText(2), strCutter)(1)

          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, 2) = Split(arrText(2), strCutter)(1)

            Cells(lStart, 4) = Split(arrText(2), strCutter)(9)

          Case strSearch6

            Cells(lStart, 5) = Split(arrText(2), strCutter)(3)

            lStart = lStart + 1

          End Select

          Range(Cells(lStart, 1), Cells(lStart, 8)).Replace What:=".", Replacement:="."

     End If

  Loop

  Close #1

  

End Sub

[sunny01]

Hallo Andre,

der Code funktioniert gut! Jetzt habe ich noch eine Aufgabe diesbezüglich. In IFC sind im Editor vor allem bei der Klasse IFCPROPERTYSINGLEVALUE wichtige Einträge in der zweiten Klammer, z.B. „Lagerung“ (siehe unten)

Auszug aus IFC: #215= IFCPROPERTYSINGLEVALUE('Kategorie',$,IFCLABEL('Lagerung'),$);

Könntest Du bitte den Code noch so anpassen, dass diese Werte innerhalb der zweiten Klammer (wenn vorhanden) ebenfalls zusätzlich zu den anderen Einträgen ausgelesen werden und in die Excel Tabelle eingetragen werden.

[schauan]

Hallöchen,

das wäre dann ein 7. Suchstring, ist der auch im "Rhythmus" drin? Bin gleich offline, schaue dann morgen weiter.

[sunny01]

Hallo Andre,

die Einträge sind auch im Rhythmus wie die anderen Einträge, die Du bereits in den Tabellen erfasst hast. Diese Einträge sind immer in Klammern gesetzt.

[schauan]

Hallo sunny,

oben änderst Du das:
strSearch6 = "IFCQUANTITYAREA"
strSearch7 = "IFCPROPERTYSINGLEVALUE"

und unten bei den cases fügst Du das ein:
Case strSearch7
Cells(lStart, 9) = Split(arrText(2), strCutter)(3)


Man könnte dann noch mit Replace die überflüssigen Textbestandteile entfernen.

[sunny01]

Hallo Andre,

vielen Dank für Deine Info. Bei mir gibt es nun nach dem Hinzufügen der Codezeilen immer die Fehlermeldung "Index außerhalb des gültigen Bereichs". Ich habe jedoch bereits zusätzlich zu deinen Angaben "Dim strSearch7$" am Anfang hinzugefügt. Was kann das Problem für diese Fehlermeldung sein?