Clever-Excel-Forum

Seiten: 1 2 3 4 5 6

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

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

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.

Hallo,

kann man dann das Wort "Kategorie" fest programmieren?

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.

Hallo Sunny,

was ist denn der Raumwert?

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.

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.

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?

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

Seiten: 1 2 3 4 5 6

sunny01

schauan

sunny01

schauan

sunny01

schauan

sunny01

schauan

sunny01

schauan