---

Hallo Zusammen
Ich habe ein tolles Makro (siehe Anhang) zum Übertragen einer Teileliste von IV nach Excel (Dank an Noctis79). Beim ersten Übertrag wird ein Tabellenblatt mit Namen "0" erzeugt. Wenn ich nun bei einer Korrektur (ohne Rev.) das Tabellenblatt überschreiben will, erscheint "Der eingegebene Tabellenname ist bereits vorhanden", ein Überschreiben findet nicht statt. Wie muss das Makro ergänzt oder geändert werden, damit ich das Tabellenblatt überschreiben kann, am besten per NachfrageBox?

Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Set odoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName As String
Dim oLength As String
Dim oFit As Boolean
Dim oProp As PropertySet
Dim oProp2 As PropertySet
Dim i As Property
Dim e As Property
Dim oDescription As String
Dim oTitle As String
Dim oPartNumber As String
Dim oRevision As String
Dim oCreationDate As String
Set oProp = odoc.PropertySets.Item("Design Tracking Properties")
Set oProp2 = odoc.PropertySets.Item("Inventor Summary Information")
For Each i In oProp
If i.DisplayName = "Bauteilnummer" Then
oPartNumber = i.Expression
ElseIf i.DisplayName = "Erstellungsdatum" Then
oCreationDate = i.Expression
End If
Next
For Each e In oProp2
If e.DisplayName = "Titel" Then
oTitle = e.Expression
End If
Next
oFileName = oPartNumber & "." & oTitle & ".xls"
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

oXLSFileName = "M:\Stücklisten\Dila\" & oFileName
Dim oPropRev As PropertySet
Dim iRev As Property
Set oPropRev = odoc.PropertySets.Item("Inventor Summary Information")
For Each iRev In oPropRev
If iRev.DisplayName = "Revisionsnummer" Then
If iRev.Expression = "" Then
oName = "0"
Else
oName = iRev.Expression
End If
End If
Next
'oStart = Start- Zelle
oStart = "A5"
'oTemplate = Pfad zum xls- Template
oTemplate = "M:\Stücklisten\01-StücklisteVorlage.xls"
'oFit bewirkt, dass die Zellen eingepasst werden
'true - Zellen werden angepasst
'false - Zellen werden nicht angepasst
oFit = False
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
Call oOptions.Add("AutoFitColumnWidth", oFit)
If odoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf odoc.ActiveSheet.PartsLists.Count > 1 Then
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!" _
, vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
'************************* Ab hier der EXCEL- PART ****************
'Im Inventor VBA- Projekt auf Extras - Verweise und
'die Microsoft Excel Library hinzufügen
'******************************************************************
Dim oExl As New Excel.Application
On Error Resume Next
Set oExl = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
On Error Resume Next
Set oExl = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
End If
End If

oExl.Workbooks.Open (oXLSFileName)
With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oTitle
.Sheets(oName).Cells(2, 4) = oRevision
.Sheets(oName).Cells(4, 1) = oCreationDate
.Close 1
End With
End Sub

------------------
Didi

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

---

Hi

Das Problem liegt hier:

Code:

---

Call oOptions.Add("TableName", oName)
...
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)

---

Du versuchst in eine bestehende Exceldatei auf ein neu erstelltes Tabellenblatt 0 zu exportieren. Das Blatt gibt'S schon, also geht's schief. Müßtest du vorab in der Exceldatei nachsehen, ob das Blatt schon da ist und es löschen.

------------------
MfG
RK

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

---

Hallo rkauskh
Danke für die schnelle Antwort.
Das Problem ist mir schon bekannt und momentan mache ich das auch so.
Ich suche allerdings eine Lösung, das ganze in diesem Makro zu "automatisieren" sprich: ist das Tabellenblatt vorhanden soll mir eine MsgBox die Möglichkeit zu löschen bzw überschreiben oder abzubrechen anbieten. Für einen passenden Tip wäre ich dankbar.

------------------
Didi

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

---

Hi

Dann würde ich die Reihenfolge ändern:

- Prüfen ob gleichnamige Datei existiert
- wenn ja, Excel starten und Datei öffnen
  - alle Tabellenblätter prüfen, ob eines mit der gleichen Nummer wie in oName existiert
  - wenn ja, löschen (sollte etwa so gehen: oExl.ActiceWorkbook.Sheets(oName).delete)
    - Datei schließen und dabei speichern
- Export starten
- Datei wiederum öffnen und die iProps übertragen

Code kann ich dir gerade nicht liefern - Zeitmangel, sorry

------------------
MfG
RK

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

---

Hallo rkauskh

Ich bin in VBA leider nicht so fit und mein Englisch lässt zu wünschen übrig, so tu ich mich doch schwer, Deinen Vorschlag umzusetzen. Solltest Du Zeit und Musse haben, diesen Part zu programmieren, wäre ich Dir sehr dankbar.

------------------
Didi

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

---

Hi

Alles ungetestet, könnte also voll daneben gehen:

Code:

---

Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Set odoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName As String
Dim oLength As String
Dim oFit As Boolean
Dim oProp As PropertySet
Dim oProp2 As PropertySet
Dim i As Property
Dim e As Property
Dim oDescription As String
Dim oTitle As String
Dim oPartNumber As String
Dim oRevision As String
Dim oCreationDate As String
Set oProp = odoc.PropertySets.Item("Design Tracking Properties")
Set oProp2 = odoc.PropertySets.Item("Inventor Summary Information")
For Each i In oProp
If i.DisplayName = "Bauteilnummer" Then
oPartNumber = i.Expression
ElseIf i.DisplayName = "Erstellungsdatum" Then
oCreationDate = i.Expression
End If
Next
For Each e In oProp2
If e.DisplayName = "Titel" Then
oTitle = e.Expression
End If
Next
oFileName = oPartNumber & "." & oTitle & ".xls"
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

oXLSFileName = "M:\Stücklisten\Dila\" & oFileName
Dim oPropRev As PropertySet
Dim iRev As Property
Set oPropRev = odoc.PropertySets.Item("Inventor Summary Information")
For Each iRev In oPropRev
If iRev.DisplayName = "Revisionsnummer" Then
If iRev.Expression = "" Then
oName = "0"
Else
oName = iRev.Expression
End If
End If
Next
'oStart = Start- Zelle
oStart = "A5"
'oTemplate = Pfad zum xls- Template
oTemplate = "M:\Stücklisten\01-StücklisteVorlage.xls"
'oFit bewirkt, dass die Zellen eingepasst werden
'true - Zellen werden angepasst
'false - Zellen werden nicht angepasst
oFit = False
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
Call oOptions.Add("AutoFitColumnWidth", oFit)
If odoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf odoc.ActiveSheet.PartsLists.Count > 1 Then
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!" _
, vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If

'Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)

'************************* Ab hier der EXCEL- PART ****************
'Im Inventor VBA- Projekt auf Extras - Verweise und
'die Microsoft Excel Library hinzufügen
'******************************************************************
Dim oExl As New Excel.Application
On Error Resume Next
Set oExl = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
On Error Resume Next
Set oExl = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
Exit Sub
End If
End If

On Error Resume Next
oExl.Workbooks.Open (oXLSFileName)
If Err.Number Then
Err.Clear
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
Else
Dim oExlSheet As Excel.WorkSheet
For Each oExlSheet In oExl.ActiveWorkbook
If oExlSheet.Name = oName Then
    oExlSheet.Delete
End If
Next
oExl.ActiveWorkbook.Close (True)
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
End If

With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oTitle
.Sheets(oName).Cells(2, 4) = oRevision
.Sheets(oName).Cells(4, 1) = oCreationDate
.Close 1
End With
End Sub

---

------------------
MfG
RK

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

---

Hi

Ich habe das Macro mal 1:1 übernommen und ausprobiert.
Das ganze bleibt in einer Endlosschleife hängen (kein Debug).
Ich denke, ein Aufruf ist zu viel oder an der falschen Stelle.
Da ich in VBA nicht so bewandert bin, ist das nur eine Vermutung.

------------------
Didi

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

---

Hi

Probier's mal so:

Code:

---

Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Set odoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName As String
Dim oLength As String
Dim oFit As Boolean
Dim oProp As PropertySet
Dim oProp2 As PropertySet
Dim i As Property
Dim e As Property
Dim oDescription As String
Dim oTitle As String
Dim oPartNumber As String
Dim oRevision As String
Dim oCreationDate As String
Set oProp = odoc.PropertySets.Item("Design Tracking Properties")
Set oProp2 = odoc.PropertySets.Item("Inventor Summary Information")
For Each i In oProp
If i.DisplayName = "Bauteilnummer" Then
oPartNumber = i.Expression
ElseIf i.DisplayName = "Erstellungsdatum" Then
oCreationDate = i.Expression
End If
Next
For Each e In oProp2
If e.DisplayName = "Titel" Then
oTitle = e.Expression
End If
Next
oFileName = oPartNumber & "." & oTitle & ".xls"
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

oXLSFileName = "M:\Stücklisten\Dila\" & oFileName
Dim oPropRev As PropertySet
Dim iRev As Property
Set oPropRev = odoc.PropertySets.Item("Inventor Summary Information")
For Each iRev In oPropRev
If iRev.DisplayName = "Revisionsnummer" Then
If iRev.Expression = "" Then
oName = "0"
Else
oName = iRev.Expression
End If
End If
Next
'oStart = Start- Zelle
oStart = "A5"
'oTemplate = Pfad zum xls- Template
oTemplate = "M:\Stücklisten\01-StücklisteVorlage.xls"
'oFit bewirkt, dass die Zellen eingepasst werden
'true - Zellen werden angepasst
'false - Zellen werden nicht angepasst
oFit = False
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
Call oOptions.Add("AutoFitColumnWidth", oFit)
If odoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf odoc.ActiveSheet.PartsLists.Count > 1 Then
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!" _
, vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If

'Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)

'************************* Ab hier der EXCEL- PART ****************
'Im Inventor VBA- Projekt auf Extras - Verweise und
'die Microsoft Excel Library hinzufügen
'******************************************************************
Dim oExl As New Excel.Application
On Error Resume Next
Set oExl = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
On Error Resume Next
Set oExl = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
Exit Sub
End If
End If

On Error Resume Next
oExl.Workbooks.Open (oXLSFileName)
If Err.Number Then
    Err.Clear
    Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
    oExl.Workbooks.Open (oXLSFileName)
Else
    Dim oExlSheet As Excel.WorkSheet
    For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
        If oExlSheet.Name = oName Then
            oExl.DisplayAlerts = False
            oExlSheet.Delete
            oExl.DisplayAlerts = True
        End If
    Next
oExl.ActiveWorkbook.Close (True)
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
End If

'Löscht alle Tabellenblätter, die mit "Tabelle" beginnen
For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
    If Left(oExlSheet.Name, 7) = "Tabelle" Then
        oExlSheet.Delete
    End If
Next

With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oTitle
.Sheets(oName).Cells(2, 4) = oRevision
.Sheets(oName).Cells(4, 1) = oCreationDate
.Close 1
End With
End Sub

---

------------------
MfG
RK

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

---

Hi,
ich habe das Macro ausprobiert. Hier mein Ergebnis:
1) Wenn noch keine Liste angelegt (übergeben) ist kommt die Fehlermeldung von MS-Excel "M:\Stückliste....kann nicht gefunden werden. Überprüfen Sie...". Nach Bestätigung auf ok wird die Liste angelegt.
2) Möchte ich diese Liste ohne Änderung noch einmal übergeben kommt die Meldung von IV2012 "Der eingegebene Tabellenname ist bereits vorhanden" Nach Bestätigung auf ok wird die Liste nicht übergeben.
3) Ändere ich aber die Rev.nummer, wird die Liste wieder übergeben und ein neues Tabellenblatt angelegt und nun funktionieren alle weiteren Übergaben ohne eine Änderung vorzunehmen.
Liegt das an Fehlermeldung 1)?
Kann eine Abfrage eingebaut werden "Liste vorhanden -"überschreiben"; "abbrechen" ?

liebe Grüße

------------------
Didi

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

---

Hi,

die Abfrage habe ich gelöst:
........
Else
    Dim oExlSheet As Excel.WorkSheet
    Dim m As Integer
    For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
        If oExlSheet.Name = oName Then
        m = MsgBox("soll vorhandene Liste überschrieben werde?", 1, "Listenabfrage")
            If m = 2 Then
            Exit Sub
            ElseIf m = 1 Then
            oExl.DisplayAlerts = False
            oExlSheet.Delete
            oExl.DisplayAlerts = True
        End If
        End If
Next
oExl.ActiveWorkbook.Close (True)..........
................

Bleibt nur noch, warum das Macro beim 1.mal überschreiben nicht funktioniert.

------------------
Didi

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

---

Hi

Die Antowrt ist simpel. Excel läßt nicht zu das einzige vorhandene Tabellenblatt zu löschen. Schummeln wir uns halt drumrum und fügen ein Dummyblatt ein, daß später wieder gelöscht wird.

Code:

---

Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Set odoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName As String
Dim oLength As String
Dim oFit As Boolean
Dim oProp As PropertySet
Dim oProp2 As PropertySet
Dim i As Property
Dim e As Property
Dim oDescription As String
Dim oTitle As String
Dim oPartNumber As String
Dim oRevision As String
Dim oCreationDate As String
Set oProp = odoc.PropertySets.Item("Design Tracking Properties")
Set oProp2 = odoc.PropertySets.Item("Inventor Summary Information")
For Each i In oProp
If i.DisplayName = "Bauteilnummer" Then
oPartNumber = i.Expression
ElseIf i.DisplayName = "Erstellungsdatum" Then
oCreationDate = i.Expression
End If
Next
For Each e In oProp2
If e.DisplayName = "Titel" Then
oTitle = e.Expression
End If
Next
oFileName = oPartNumber & "." & oTitle & ".xls"
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

oXLSFileName = "M:\Stücklisten\Dila\" & oFileName
Dim oPropRev As PropertySet
Dim iRev As Property
Set oPropRev = odoc.PropertySets.Item("Inventor Summary Information")
For Each iRev In oPropRev
If iRev.DisplayName = "Revisionsnummer" Then
If iRev.Expression = "" Then
oName = "0"
Else
oName = iRev.Expression
End If
End If
Next
'oStart = Start- Zelle
oStart = "A5"
'oTemplate = Pfad zum xls- Template
oTemplate = "M:\Stücklisten\01-StücklisteVorlage.xls"
'oFit bewirkt, dass die Zellen eingepasst werden
'true - Zellen werden angepasst
'false - Zellen werden nicht angepasst
oFit = False
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
Call oOptions.Add("AutoFitColumnWidth", oFit)
If odoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf odoc.ActiveSheet.PartsLists.Count > 1 Then
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!" _
, vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If

'Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)

'************************* Ab hier der EXCEL- PART ****************
'Im Inventor VBA- Projekt auf Extras - Verweise und
'die Microsoft Excel Library hinzufügen
'******************************************************************
Dim oExl As New Excel.Application
On Error Resume Next
Set oExl = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
On Error Resume Next
Set oExl = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
Exit Sub
End If
End If

On Error Resume Next
oExl.Workbooks.Open (oXLSFileName)
If Err.Number Then
    Err.Clear
    Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
    oExl.Workbooks.Open (oXLSFileName)
Else
    Dim oExlSheet As Excel.WorkSheet
    For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
        If oExlSheet.Name = oName Then
            If oExl.ActiveWorkbook.Worksheets.Count = 1 Then
                oExl.ActiveWorkbook.Worksheets.Add
            End If
            oExl.DisplayAlerts = False
            oExlSheet.Delete
            oExl.DisplayAlerts = True
        End If
    Next
oExl.ActiveWorkbook.Close (True)
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
End If

'Löscht alle Tabellenblätter, die mit "Tabelle" beginnen
For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
    If Left(oExlSheet.Name, 7) = "Tabelle" Then
        oExlSheet.Delete
    End If
Next

With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oTitle
.Sheets(oName).Cells(2, 4) = oRevision
.Sheets(oName).Cells(4, 1) = oCreationDate
.Close 1
End With
End Sub

---

------------------
MfG
RK

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

---

Hallo RKausKH,

das funktioniert jetzt gut, bleibt aber noch das Problem mit der erstmaligen Übergabe einer Stückliste von IV nach Excel. Wie oben schon genannt......
  1) Wenn noch keine Liste angelegt (übergeben) ist kommt die Fehlermeldung von MS-Excel "M:\Stückliste..blabla..kann nicht gefunden werden. Überprüfen Sie..blabla..". Nach Bestätigung auf ok wird die Liste angelegt.
------------
Da ich an 2 Monitore arbeite und auf beiden Bildschirmen Programme geöffnet sind, passiert es, dass dieser Hinweis verdeckt im Hintergrund ist und ich erst über den Taskmanager daran komme. Es wird ja eine Bestätigung erwartet.
Aber ich denke, das kann man auch irgendwie lösen.
Schon jetzt danke für Dein Engagement.

Liebe Grüsse

------------------
Didi

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

---

Hi,

ich habe mich einmal daran probiert und eine Lösung gefunden:
......

Code:

---

    If Dir(oXLSFileName) <> "" Then
  oExl.Workbooks.Open (oXLSFileName)
    Else
    GoTo ErrorHandler    End If
 
If Err.Number Then
Err.Clear
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
Else
Dim oExlSheet As Excel.WorkSheet
Dim m As Integer
For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
If oExlSheet.Name = oName Then

    m = MsgBox("soll vorhandene Liste überschrieben werden?", 1, "Listenabfrage")
            If m = 2 Then
            Exit Sub
            ElseIf m = 1 Then

If oExl.ActiveWorkbook.Worksheets.Count = 1 Then
oExl.ActiveWorkbook.Worksheets.Add
End If
End If
oExl.DisplayAlerts = False
oExlSheet.Delete
oExl.DisplayAlerts = True
End If

Next

ErrorHandler:oExl.ActiveWorkbook.Close (True)
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
End If
'Löscht alle Tabellenblätter, die mit "Tabelle" beginnen
For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
If Left(oExlSheet.Name, 7) = "Tabelle" Then
oExlSheet.Delete
End If
Next

With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oTitle
.Sheets(oName).Cells(2, 4) = oName
.Sheets(oName).Cells(4, 1) = oCreationDate
.Close 1
End With
End Sub

---

Bei mir funktioniert es jetzt
Herzlichen Dank für die wertvolle Unterstützung.

Liebe Grüße

------------------
Didi

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