---

Hallo Cad Gemeine,

Ich habe da ein kleines Problem ich habe mir da ein Skript gepaspelt, was mir den Strukturbaum Ausliest und dieses dann aufteilt.
Leider weiß ich die Code Zeilen nicht, um die ausgelesenen Werte mir in Excel zu schreiben.
Hoffe es kann mir jemand Helfen

Das erzeugen einer Excel ist schon im Skript eingebaut.
Die Ergebnisse so wie ich sie haben möchte werden auch in einer MsgBox
Richtig ausgegeben. Nur die Excel Tabelle bleibt Leer

msgbox "Name:" + vTXT + Chr(13) + Chr(13) +  "Anz.  ....usw....

Diese Zeilen habe ich. (In einer einfachen Schleife funktoniert es)

Code:

---

objXL.ActiveWorkbook.Worksheets(1)
objXL.Cells(i,1).Value = vTXT ' "DAS IST Spalte" &  i
objXL.Cells(i,2).Value = TXT1 '"DAS IST Spalte" &  i & "Zelle 2"
objXL.Cells(i,3).Value = TXT2 ' "DAS IST Spalte" &  i &  "Zelle 3"
objXL.Cells(i,4).Value = TXT2 ' "DAS IST Spalte" &  i &  "Zelle 3"

---

.... usw.......

Nur wo baue ich diese Zeilen in das Skript ein?

Code:

---

'Option Explicit
'arrays fangen beim Index 0 an...
Dim aAssyArray() As String 'input array
Dim iAssyArrayCount As Integer
Dim aStuliPartNumbers() As String 'output array, Benennung
Dim aStuliCounts() As Integer 'output array, Anzahl

Sub CATMain()

Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
Set oAWBook = objxl.Workbooks.Add

X

end Sub

Sub X

Set objXL = CreateObject("Excel.Application")

Dim oActDoc As Document
If CATIA.Documents.Count = 0 Then
MsgBox ("Kein Dokument geöffnet!")
Exit Sub
End If

Set oActDoc = CATIA.ActiveDocument

If TypeName(oActDoc) <> "ProductDocument" Then
MsgBox ("Kein Product geladen!")
Exit Sub
End If

'Array wird auf 100 EintrÀge initialisiert
'im RekursivDurchBaum ist die Redimensionierung vorhanden
ReDim aAssyArray(100)
iAssyArrayCount = 0
Dim oProduct As Product
Set oProduct = oActDoc.Product
Dim oProducts As Products
Set oProducts = oProduct.Products
'Alle CATParts aus Baum ins globale Array sammeln
RekursivDurchBaum oProducts
If iAssyArrayCount > 0 Then

'Arraydimension zurechtschneiden
ReDim Preserve aAssyArray(iAssyArrayCount - 1)
StuliEintraegeZaehlen
'Ausgabe der Ergebnis ins Immedate Window (VBA)

Dim i As Integer
Dim sTemp As String
Dim sTempAnz As String
Dim vTXT As String
Dim BenennTXT As String
Dim PosTXT1 As String
Dim PosTXT2 As String
Dim AuftragNrTXT1 As String

Dim bgTXT1 As String
Dim bgTXT2 As String

Dim TXT_W_Teil As String
Dim TXT_1_W_Teil As String
Dim W_Teil As String
Dim KT_Teil As String
Dim Bestell As String
Dim Bestellx As String
Dim Liefer As String
Dim Lieferx As String
Dim Name As String
Dim Namex As String

Dim Baugr1 As String
Dim Baugr2 As String
Dim Baugr As String

Dim TXT_ As String
Dim TXT_1 As String
Dim TXT_2 As String
Dim TXT_3 As String
Dim TXT_4 As String
Dim TXT_5 As String
Dim TXT_6 As String
Dim TXT_7 As String
Dim TXT_8 As String
Dim TXT_9 As String
Dim BG_B As String
Dim BauGru_B As String
Dim BauGru_U As String

Dim TXT1 As String
Dim TXT2 As String
Dim TXT3 As String
Dim TXT4 As String
Dim TXT5 As String
Dim TXT6 As String
Dim TXT7 As String
Dim TXT8 As String
For i = LBound(aStuliPartNumbers) To UBound(aStuliPartNumbers)
sTemp = CInt(aStuliCounts(i)) & " St. von " & aStuliPartNumbers(i)
'Debug.Print sTemp
'hier kann auch ein Msgbox stehen
'MsgBox (sTemp)
sTempAnz = "" & CInt(aStuliCounts(i))
'Msgbox sTempAnz

'######################################## ETZ ###############################################

On Error Resume Next

vTXT =  aStuliPartNumbers(i)
'vTXT = Left(Name, InStrRev(Name, ".CAT") - 1)

BenennTXT = Right( vTXT, Len( vTXT) -18 ) 'Right Left

PosTXT1 = Left(vTXT, InStrRev(vTXT, "_") - 1)
PosTXT2 = Right( PosTXT1, Len(PosTXT1) -14 ) 'Right Left

AuftragNrTXT1 = Left( PosTXT1, Len( PosTXT1) -9 ) 'Right Left

bgTXT1 = Left( PosTXT1, Len( PosTXT1) -5 ) 'Right Left
bgTXT2 = Right( bgTXT1, Len( bgTXT1) -9 ) 'Right Left

'________________________________________________________________________________________________

TXT_W_Teil = Left(vTXT, InStrRev(vTXT, "_") -1)  'Right Left Mid
TXT_1_W_Teil = Right(TXT_W_Teil, InStrRev(TXT_W_Teil, "_") -5)  'Right Left Mid
W_Teil = Left(TXT_1_W_Teil, Len(TXT_1_W_Teil) -7)  'Right Left

'##############################################################################################

'########################### Kaufteile #######################################################

KT_Teil = Left(vTXT, InStrRev(vTXT, "KT_") +2)  'Right Left Mid

Bestell = mid(vTXT, InStrRev(vTXT, "_") +1)  'Right Left Mid
Bestellx = Left(vTXT, InStrRev(vTXT, "_") -1)  'Right Left Mid

Liefer = mid(Bestellx, InStrRev(Bestellx, "_") +1)  'Right Left Mid
Lieferx = Left(Bestellx, InStrRev(Bestellx, "_") -1)  'Right Left Mid

Name = mid(Lieferx, InStrRev(Lieferx, "_") +1)  'Right Left Mid
Namex = Left(Lieferx, InStrRev(Lieferx, "_") -1)  'Right Left Mid

'###################################### Baugruppe untersch #######################################################

Baugr1 = Left(vTXT, InStrRev(vTXT, "_") -1)  'Right Left Mid
Baugr2 = Left(Baugr1, InStrRev(Baugr1, "_") +1)  'Right Left Mid
Baugr = mid(Baugr2, InStrRev(Baugr2, "_") -0)  'Right Left Mid

'#################################################################################################

TXT_5 = Right(TXT_4, InStrRev(TXT_4, "_") -0)  'Right Left Mid
TXT_6 = Left(TXT_5, InStrRev(TXT_, "_") -6)  'Right Left Mid

TXT_8 = Left(TXT_5, InStrRev(TXT_, "_") -6)  'Right Left Mid
TXT_9 = Right(TXT_8, Len(TXT_8) - 1)

TXT_1_BG_B = Left(TXT_2_BG_U, InStrRev(TXT_, "_") -6)  'Right Left Mid
BG_B = Right(TXT_1_BG_B, Len(TXT_1_BG_B) - 1)

'msgbox oName + Chr(13) + "oName"
'msgbox TXT_1 + Chr(13) + "TXT_1"
'msgbox W_Teil + Chr(13) + "W_Teil"
'msgbox Baugr1 + Chr(13) + "Baugr1"
'msgbox Baugr2 + Chr(13) + "Baugr2"
'msgbox Baugr + Chr(13) + "Baugr"
'msgbox TXT_6 + Chr(13) + "TXT_6"
'msgbox TXT_7 + Chr(13) + "TXT_7"
'msgbox TXT_8 + Chr(13) + "TXT_8"
'msgbox TXT_9 + Chr(13) + "TXT_9"

'#############################################################################################

BauGru_B = vTXT & Chr(10) & "Baugruppe"

BauGru_U = vTXT & Chr(10) & "Unterbaugruppe"

'######################## IF ABFRAGE #########################################################

'if Baugr = "_B" Then

' TXT1 = ""
' TXT2 = BauGru_B
' TXT3 = ""
' TXT4 = ""
' TXT5 = ""
' TXT6 = ""
' TXT7 = ""
'end if

'if Baugr = "_U" Then

' TXT1 = ""
' TXT2 = BauGru_U
' TXT3 = ""
' TXT4 = ""
' TXT5 = ""
' TXT6 = ""
' TXT7 = ""

'end if

if W_Teil = "-B" Then

TXT1= sTempAnz
TXT2= BenennTXT
TXT3= PosTXT1
TXT4= ""
TXT5= PosTXT2
TXT6= ""
TXT7= "Werner"
'TXT2= "IF Abfrage -B"  & Chr(13) & oName
end if

if KT_Teil = "KT_" Then

TXT1 = sTempAnz
TXT2 = Name
TXT3 = ""
TXT4 = ""
TXT5 = ""
TXT6 = Bestell
TXT7 = Liefer

end if

msgbox "Name:" + vTXT + Chr(13) + Chr(13) +  "Anz.:                            " + TXT1 + Chr(13) + "Bennennung:              " + TXT2 + Chr(13) + "Best-Nr.Werner:          " + TXT3 +  Chr(13) + "Werkstoff:                  " + TXT4 + Chr(13)  + "Pos.                            " +  TXT5 + Chr(13) + "Rohmasse-DIN:        "  + TXT6 + Chr (13) +  "Lifer:                        " + TXT7

vTXT = " "
TXT1 = " "
TXT2 = " "
TXT3 = " "
TXT4 = " "
TXT5 = " "
TXT6 = " "
TXT7 = " "

objXL.ActiveWorkbook.Worksheets(1)
objXL.Cells(i,1).Value = vTXT ' "DAS IST Spalte" &  i
objXL.Cells(i,2).Value = TXT1 '"DAS IST Spalte" &  i & "Zelle 2"
objXL.Cells(i,3).Value = TXT2 ' "DAS IST Spalte" &  i &  "Zelle 3"
objXL.Cells(i,4).Value = TXT2 ' "DAS IST Spalte" &  i &  "Zelle 3"

Next

End If

End Sub

Function RekursivDurchBaum(oProducts As Products)
Dim oProduct As Product
Dim oRefProduct As Product
Dim oRefDocument As Document
For Each oProduct In oProducts
If oProduct.Products.Count > 0 Then
RekursivDurchBaum oProduct.Products
Else
Set oRefProduct = oProduct.ReferenceProduct
Set oRefDocument = oRefProduct.Parent
If TypeName(oRefDocument) = "PartDocument" Then
'Du bist an einen Part
'jetzt kannst du entscheiden, nach was du zÀhlen willst:
' 'Dateiname
aAssyArray(iAssyArrayCount) = oRefDocument.Name
'PartNumber
aAssyArray(iAssyArrayCount) = oRefProduct.PartNumber
iAssyArrayCount = iAssyArrayCount + 1
'dieser Block ist nur da, falls die Anzahl der Products ÃŒber 100 kommen sollte
If UBound(aAssyArray) <= iAssyArrayCount Then
ReDim Preserve aAssyArray(iAssyArrayCount + 20)
End If
End If
End If
Next
End Function
Sub StuliEintraegeZaehlen()
Dim i1stLoop As Integer
Dim i2ndLoop As Integer
Dim iSearchStringCount As Integer
Dim sSearchString As String
Dim iStuliArrayCount As Integer
Dim s2ndLoopString As String
ReDim aStuliPartNumbers(20) 'output array, Benennung
ReDim aStuliCounts(20) 'output array, Anzahl
iStuliArrayCount = 0
'Algorithmus:
'Es wird die aAssyArray durchgelaufen. Jede Zeile dieser Array wird in aStuli*
'geschrieben, falls es noch nicht existiert. Falls ein Eintrag mit der selber Name
'schon vorhanden war, wird der ZÀhler (2. Spalte) inkrementiert
'Bei jeder Treffer wird der Eintrag aus der Originalarray gelöscht
'habe im Vergleich zur VorgÀnger lieber zwei Eindimensionale Arrays genommen, somit sind die
'einfacher zu handhaben
'Àußere Schleife
For i1stLoop = 0 To iAssyArrayCount - 1
iSearchStringCount = 0
sSearchString = CStr(aAssyArray(i1stLoop)) 'nach diesen wird weitergesucht
If Len(sSearchString) > 0 Then 'also Eintrag im Original noch nicht gelöscht
iSearchStringCount = iSearchStringCount + 1 'ein Eintrag haben wir jedenfalls schon gefunden
'innere Schleife
For i2ndLoop = i1stLoop + 1 To iAssyArrayCount - 1
s2ndLoopString = CStr(aAssyArray(i2ndLoop))
If Len(s2ndLoopString) > 0 Then 'also Eintrag im Original noch nicht gelöscht
If s2ndLoopString = sSearchString Then 'wir haben noch ein Exemplar gefunden
iSearchStringCount = iSearchStringCount + 1
aAssyArray(i2ndLoop) = "" 'OriginalEintrag löschen
End If
End If
Next
'nachdem die GesamtstÃŒckzahl ermittelt wurde, wird es ins Ausgangsarray geschreiben
aStuliPartNumbers(iStuliArrayCount) = sSearchString
aStuliCounts(iStuliArrayCount) = iSearchStringCount
'wieder der Array Dimensionscheck
iStuliArrayCount = iStuliArrayCount + 1
If UBound(aStuliPartNumbers) <= iStuliArrayCount Then
ReDim Preserve aStuliPartNumbers(iStuliArrayCount + 5)
ReDim Preserve aStuliCounts(iStuliArrayCount + 5)
End If
End If
Next
If iStuliArrayCount > 0 Then
'Arraydimension zurechtschneiden
ReDim Preserve aStuliPartNumbers(iStuliArrayCount - 1)
ReDim Preserve aStuliCounts(iStuliArrayCount - 1)
End If
End Sub

---

------------------
Sei Schlau bleib Dumm !!?!! 

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Servus
An der Stelle wo du den Code zum schreiben der Wert in Excel eingebaut hast wurde die Strings gerade wieder geleert, also vor den Zeile vTXT = " " einbauen

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo. Bernd,

Danke für deine Antwort.

Leider bleibt das Ergehbiss das gleiche Excel bleibt leer. 
Auch ein ausklammern der  Zeilen zum Leeren der Werte bringt nix. 

------------------
Sei Schlau bleib Dumm !!?!! 

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Servus
Welches Worksheet wird verwendet? Müsse es nicht:
objXL.ActiveWorkbook.Worksheets(1).Cells(i,1).Value = vTXT ' "DAS IST Spalte" &  i
heißen? Ist die Variable im in diesem Moment gesetzt?

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Servus

Manchmal sieht man den Wald vor lauter Bäumen nicht mehr !!!!!!
Danke deiner denk Anstöße funktioniert es jetzt.

Die Variable war ja in einen andrem Sub

Hier ist der funkunierende Code.

Code:

---

'Option Explicit
'arrays fangen beim Index 0 an...
Dim aAssyArray() As String 'input array
Dim iAssyArrayCount As Integer
Dim aStuliPartNumbers() As String 'output array, Benennung
Dim aStuliCounts() As Integer 'output array, Anzahl

Sub CATMain()

Dim Box, Datei As String

Box = MsgBox ("Das Skript erzeugt eine Stueckliste:" &Chr(13) & Chr (10)  & "Sollte das Skript einen String nicht aufteilen koennen wird dieser als letztes in die Spalte (J) geschrieben ohne die Zellen davor zu befuellen." &"", 64, "StÃŒckliste")

X

end Sub

Sub X

Dim oActDoc As Document
If CATIA.Documents.Count = 0 Then
MsgBox ("Kein Dokument geöffnet!")
Exit Sub
End If

Set oActDoc = CATIA.ActiveDocument

If TypeName(oActDoc) <> "ProductDocument" Then
MsgBox ("Kein Product geladen!")
Exit Sub
End If

'Array wird auf 100 EintrÀge initialisiert
'im RekursivDurchBaum ist die Redimensionierung vorhanden
ReDim aAssyArray(100)
iAssyArrayCount = 0
Dim oProduct As Product
Set oProduct = oActDoc.Product
Dim oProducts As Products
Set oProducts = oProduct.Products
'Alle CATParts aus Baum ins globale Array sammeln
RekursivDurchBaum oProducts
If iAssyArrayCount > 0 Then

'Arraydimension zurechtschneiden
ReDim Preserve aAssyArray(iAssyArrayCount - 1)
StuliEintraegeZaehlen
'Ausgabe der Ergebnis ins Immedate Window (VBA)

Dim i As Integer
Dim sTemp As String
Dim sTempAnz As String
Dim vTXT As String
Dim BenennTXT As String
Dim PosTXT1 As String
Dim PosTXT2 As String
Dim AuftragNrTXT1 As String

Dim bgTXT1 As String
Dim bgTXT2 As String

Dim TXT_W_Teil As String
Dim TXT_1_W_Teil As String
Dim W_Teil As String
Dim KT_Teil As String
Dim Bestell As String
Dim Bestellx As String
Dim Liefer As String
Dim Lieferx As String
Dim Name As String
Dim Namex As String

Dim Baugr1 As String
Dim Baugr2 As String
Dim Baugr As String

Dim TXT_ As String
Dim TXT_1 As String
Dim TXT_2 As String
Dim TXT_3 As String
Dim TXT_4 As String
Dim TXT_5 As String
Dim TXT_6 As String
Dim TXT_7 As String
Dim TXT_8 As String
Dim TXT_9 As String
Dim BG_B As String
Dim BauGru_B As String
Dim BauGru_U As String

Dim TXT1 As String
Dim TXT2 As String
Dim TXT3 As String
Dim TXT4 As String
Dim TXT5 As String
Dim TXT6 As String
Dim TXT7 As String
Dim TXT8 As String

Dim prod As Product
'Set prod = CATIA.ActiveDocument.Product
Set objXL = CreateObject("Excel.Application")

objXL.Visible = True
Set oAWBook = objxl.Workbooks.Add

'For I = 1 to 15 'UserSelektion.Count
'For i = 1 To prod.Parameters.Count 'Parameters
'objXL.Cells(i,1).Value = "DAS IST Spalte" &  i
'objXL.Cells(i,2).Value = "DAS IST Spalte" &  i & "Zelle 2"
'objXL.Cells(i,3).Value = "DAS IST Spalte" &  i &  "Zelle 3"

'next

For i = LBound(aStuliPartNumbers) To UBound(aStuliPartNumbers)
sTemp = CInt(aStuliCounts(i)) & " St. von " & aStuliPartNumbers(i)
'Debug.Print sTemp
'hier kann auch ein Msgbox stehen
'MsgBox (sTemp)
sTempAnz = "" & CInt(aStuliCounts(i))
'Msgbox sTempAnz

'######################################## ETZ ###############################################

On Error Resume Next

vTXT =  aStuliPartNumbers(i)
'vTXT = Left(Name, InStrRev(Name, ".CAT") - 1)

BenennTXT = Right( vTXT, Len( vTXT) -18 ) 'Right Left

PosTXT1 = Left(vTXT, InStrRev(vTXT, "_") - 1)
PosTXT2 = Right( PosTXT1, Len(PosTXT1) -14 ) 'Right Left

AuftragNrTXT1 = Left( PosTXT1, Len( PosTXT1) -9 ) 'Right Left

bgTXT1 = Left( PosTXT1, Len( PosTXT1) -5 ) 'Right Left
bgTXT2 = Right( bgTXT1, Len( bgTXT1) -9 ) 'Right Left

'________________________________________________________________________________________________

TXT_W_Teil = Left(vTXT, InStrRev(vTXT, "_") -1)   'Right Left Mid
TXT_1_W_Teil = Right(TXT_W_Teil, InStrRev(TXT_W_Teil, "_") -5)   'Right Left Mid
W_Teil = Left(TXT_1_W_Teil, Len(TXT_1_W_Teil) -7)   'Right Left

'##############################################################################################

'########################### Kaufteile #######################################################

KT_Teil = Left(vTXT, InStrRev(vTXT, "KT_") +2)   'Right Left Mid

Bestell = mid(vTXT, InStrRev(vTXT, "_") +1)   'Right Left Mid
Bestellx = Left(vTXT, InStrRev(vTXT, "_") -1)   'Right Left Mid

Liefer = mid(Bestellx, InStrRev(Bestellx, "_") +1)   'Right Left Mid
Lieferx = Left(Bestellx, InStrRev(Bestellx, "_") -1)   'Right Left Mid

Name = mid(Lieferx, InStrRev(Lieferx, "_") +1)   'Right Left Mid
Namex = Left(Lieferx, InStrRev(Lieferx, "_") -1)   'Right Left Mid

'###################################### Baugruppe untersch #######################################################

Baugr1 = Left(vTXT, InStrRev(vTXT, "_") -1)   'Right Left Mid
Baugr2 = Left(Baugr1, InStrRev(Baugr1, "_") +1)   'Right Left Mid
Baugr = mid(Baugr2, InStrRev(Baugr2, "_") -0)   'Right Left Mid

'#################################################################################################

TXT_5 = Right(TXT_4, InStrRev(TXT_4, "_") -0)   'Right Left Mid
TXT_6 = Left(TXT_5, InStrRev(TXT_, "_") -6)   'Right Left Mid

TXT_8 = Left(TXT_5, InStrRev(TXT_, "_") -6)   'Right Left Mid
TXT_9 = Right(TXT_8, Len(TXT_8) - 1)

TXT_1_BG_B = Left(TXT_2_BG_U, InStrRev(TXT_, "_") -6)   'Right Left Mid
BG_B = Right(TXT_1_BG_B, Len(TXT_1_BG_B) - 1)

'msgbox oName + Chr(13) + "oName"
'msgbox TXT_1 + Chr(13) + "TXT_1"
'msgbox W_Teil + Chr(13) + "W_Teil"
'msgbox Baugr1 + Chr(13) + "Baugr1"
'msgbox Baugr2 + Chr(13) + "Baugr2"
'msgbox Baugr + Chr(13) + "Baugr"
'msgbox TXT_6 + Chr(13) + "TXT_6"
'msgbox TXT_7 + Chr(13) + "TXT_7"
'msgbox TXT_8 + Chr(13) + "TXT_8"
'msgbox TXT_9 + Chr(13) + "TXT_9"

'#############################################################################################

BauGru_B = vTXT & Chr(10) & "Baugruppe"

BauGru_U = vTXT & Chr(10) & "Unterbaugruppe"

'######################## IF ABFRAGE #########################################################

if W_Teil = "-B" Then

TXT1= sTempAnz
TXT2= BenennTXT
TXT3= PosTXT1
TXT4= ""
TXT5= PosTXT2
TXT6= ""
TXT7= "Werner"

end if

if KT_Teil = "KT_" Then

TXT1 = sTempAnz
TXT2 = Name
TXT3 = ""
TXT4 = ""
TXT5 = ""
TXT6 = Bestell
TXT7 = Liefer

end if

'msgbox "Name:" + vTXT + Chr(13) + Chr(13) +  "Anz.:                             " + TXT1 + Chr(13) + "Bennennung:               " + TXT2 + Chr(13) + "Best-Nr.Werner:          " + TXT3 +  Chr(13) + "Werkstoff:                   " + TXT4 + Chr(13)  + "Pos.                            " +  TXT5 + Chr(13) + "Rohmasse-DIN:         "  + TXT6 + Chr (13) +  "Lifer:                         " + TXT7

'http://ww3.cad.de/foren/ubb/Forum137/HTML/000866.shtml#000006

objXL.Cells(i,1).Value = TXT1 '"DAS IST Spalte" &  i & "Zelle 2"
objXL.Cells(i,2).Value = TXT2 ' "DAS IST Spalte" &  i &  "Zelle 3"
objXL.Cells(i,3).Value = TXT3 ' "DAS IST Spalte" &  i &  "Zelle 4"
objXL.Cells(i,4).Value = TXT4 ' "DAS IST Spalte" &  i &  "Zelle 5"
objXL.Cells(i,5).Value = TXT5 ' "DAS IST Spalte" &  i &  "Zelle 6"
objXL.Cells(i,6).Value = TXT6 ' "DAS IST Spalte" &  i &  "Zelle 7"
objXL.Cells(i,7).Value = TXT7 ' "DAS IST Spalte" &  i &  "Zelle 8"
objXL.Cells(i,10).Value = vTXT ' "DAS IST Spalte" &  i

vTXT = " "
TXT1 = " "
TXT2 = " "
TXT3 = " "
TXT4 = " "
TXT5 = " "
TXT6 = " "
TXT7 = " "

Next

End If

End Sub

Function RekursivDurchBaum(oProducts As Products)
Dim oProduct As Product
Dim oRefProduct As Product
Dim oRefDocument As Document
For Each oProduct In oProducts
If oProduct.Products.Count > 0 Then
RekursivDurchBaum oProduct.Products
Else
Set oRefProduct = oProduct.ReferenceProduct
Set oRefDocument = oRefProduct.Parent
If TypeName(oRefDocument) = "PartDocument" Then
'Du bist an einen Part
'jetzt kannst du entscheiden, nach was du zÀhlen willst:
' 'Dateiname
aAssyArray(iAssyArrayCount) = oRefDocument.Name
'PartNumber
aAssyArray(iAssyArrayCount) = oRefProduct.PartNumber
iAssyArrayCount = iAssyArrayCount + 1
'dieser Block ist nur da, falls die Anzahl der Products Ìber 100 kommen sollte
If UBound(aAssyArray) <= iAssyArrayCount Then
ReDim Preserve aAssyArray(iAssyArrayCount + 20)
End If
End If
End If
Next
End Function
Sub StuliEintraegeZaehlen()
Dim i1stLoop As Integer
Dim i2ndLoop As Integer
Dim iSearchStringCount As Integer
Dim sSearchString As String
Dim iStuliArrayCount As Integer
Dim s2ndLoopString As String
ReDim aStuliPartNumbers(20) 'output array, Benennung
ReDim aStuliCounts(20) 'output array, Anzahl
iStuliArrayCount = 0
'Algorithmus:
'Es wird die aAssyArray durchgelaufen. Jede Zeile dieser Array wird in aStuli*
'geschrieben, falls es noch nicht existiert. Falls ein Eintrag mit der selber Name
'schon vorhanden war, wird der ZÀhler (2. Spalte) inkrementiert
'Bei jeder Treffer wird der Eintrag aus der Originalarray gelöscht
'habe im Vergleich zur VorgÀnger lieber zwei Eindimensionale Arrays genommen, somit sind die
'einfacher zu handhaben
'ÀuÃŞere Schleife
For i1stLoop = 0 To iAssyArrayCount - 1
iSearchStringCount = 0
sSearchString = CStr(aAssyArray(i1stLoop)) 'nach diesen wird weitergesucht
If Len(sSearchString) > 0 Then 'also Eintrag im Original noch nicht gelöscht
iSearchStringCount = iSearchStringCount + 1 'ein Eintrag haben wir jedenfalls schon gefunden
'innere Schleife
For i2ndLoop = i1stLoop + 1 To iAssyArrayCount - 1
s2ndLoopString = CStr(aAssyArray(i2ndLoop))
If Len(s2ndLoopString) > 0 Then 'also Eintrag im Original noch nicht gelöscht
If s2ndLoopString = sSearchString Then 'wir haben noch ein Exemplar gefunden
iSearchStringCount = iSearchStringCount + 1
aAssyArray(i2ndLoop) = "" 'OriginalEintrag löschen
End If
End If
Next
'nachdem die GesamtstÌckzahl ermittelt wurde, wird es ins Ausgangsarray geschreiben
aStuliPartNumbers(iStuliArrayCount) = sSearchString
aStuliCounts(iStuliArrayCount) = iSearchStringCount
'wieder der Array Dimensionscheck
iStuliArrayCount = iStuliArrayCount + 1
If UBound(aStuliPartNumbers) <= iStuliArrayCount Then
ReDim Preserve aStuliPartNumbers(iStuliArrayCount + 5)
ReDim Preserve aStuliCounts(iStuliArrayCount + 5)
End If
End If
Next
If iStuliArrayCount > 0 Then
'Arraydimension zurechtschneiden
ReDim Preserve aStuliPartNumbers(iStuliArrayCount - 1)
ReDim Preserve aStuliCounts(iStuliArrayCount - 1)
End If
End Sub

---

------------------
    Sei Schlau bleib Dumm !!?!!    

[Diese Nachricht wurde von K.Siebert am 24. Dez. 2010 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

ich habe ein Problem beim auslesen von Koordinaten in ein Excel Tabelle.
Das abfragen der Werte bekomme ich hin. Ich hab hier im Forum auch ein Beispiel gefunden das für mich sehr nützlich war - jedoch in .CATScript.
Da wurde meine Excel Tabelle auch gefüllt.
Jedoch zeigt meine Tabellen nur Nullen an sobald ich den gleichen Code durch den VBA Editor nutze. Hat jemand eine Idee woran das liegen kann?

Anbei der Codeabschnitt bei dem ich die Werte in die Tabelle schreibe:

Dim acoord(2) As Variant
Dim SelElem As SelectedElement

        For i = 1 To userSel.Count
            userSel.Item(i).Value.GetCoordinates (acoord)
            Text = CInt(acoord(0)) & ";" & CInt(acoord(1)) & ";" & CInt(acoord(2))
            DStrom.Write ((i) & ";" & userSel.Item(i).Value.Name & ";" & Text & Chr(10))
        Next
        DStrom.Close

    userSel.Clear

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Servus
Wenn du den Wert in Tabelle schreiben willst musst du auch die entsprechende Zelle ansprechen. Etwa in der Art (ungetestet nur aus obigem Code kopiert):

Code:

---

objXL.Cells(i,1).Value = acoord(0)

---

Gruß
Bernd

PS: Mit Sicherheit gibt es zum Punkte Export schon genügend Makros hier im Forum zu finden.

------------------
Warum einfach, wenn es auch kompliziert geht.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi,

Danke für deine Antwort. Ich hatte auch bereits im Forum Hinweise und Beispiele gesehen. Mein Problem war so simpel wie dämlich. Damit das Makro in VBA läuft darf das "acoord" nach dem GetCoordinates NICHT in Klammern stehen. Das habe ich leider erst nach einigen Stunden herausgefunden.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP