08.05.2016, 17:27
08.05.2016, 19:12
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.
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.
08.05.2016, 21:01
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
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 Sub08.05.2016, 21:28
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.
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.
09.05.2016, 17:43
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
da ist bei mir eventuell bei den einzelnen Änderungen was untergegangen. Aber wenn's mit dem "Vorletzten" Code klappt ist ja alles gut