---

Hallo zusammen,
ich habe ein VBA Programm das ich gerne aufbohren würde. Alle Objekte unter 200 werden ausgeblendet - alle Objekte über 200 sollen neu sortiert nach Nummer und folgende soll die Objektnummer neu vergeben werden aufsteigend von 200

Hier der Code - mein Problem ist eigentlich nur die neu vergabe von Objktnummern über 200

Freue mich über jede Hilfestellung - Danke und Gruss

Public Sub StückSortZeich()

Dim oDoc As DrawingDocument
Set oDoc = ThisApplication.ActiveDocument

Dim oPartsList As PartsList
Set oPartsList = oDoc.ActiveSheet.PartsLists.Item(1)         
           
           
 
    For i = 1 To oPartsList.PartsListRows.Count
    oPartsList.PartsListRows.Item(i).Visible = True
   
 
If (oPartsList.PartsListRows.Item(i).Item("Objekt")) < 199 Then oPartsList.PartsListRows.Item(i).Visible = False
Next
   

        sPartsListSortString1 = "ESM-Nr."
        Call oPartsList.Sort(sPartsListSortString1, True)
       

          'Call oPartsList.Renumber
         
         
            'oPartsList.SaveItemOverridesToBOM

          ' For i = 1 To oPartslist.PartsListRows.Count
          ' oPartslist.PartsListRows.Item(i).Visible = True
          'If (oPartslist.PartsListRows.Item(i).Item("Objekt")) > 199 Then oPartslist.PartsListRows.Item(i).Visible = True

          '  Next

End Sub

------------------
MFG

BlueJay

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

---

Moin

Das neu nummerieren unterstützt keine Startwertvorgabe. Da hilft nur selber statisch überschreiben. Dazu musst du natürlich vorher den Index der Spalte Objekt ermitteln, da in einer Teileistenzeile die Zellen nur mit Index angesprochen werden können.
Und bitte, auch wenn es etwas mehr Mühe macht, deklariere Variablen. Das funktioniert in kleinen Makros ohne, aber in größeren sucht man sich im Fehlerfall den Wolf.

Code:

---

Option Explicit

Public Sub StückSortZeich()

Dim oDoc As DrawingDocument
Set oDoc = ThisApplication.ActiveDocument

Dim oPartsList As PartsList
Set oPartsList = oDoc.ActiveSheet.PartsLists.Item(1)

Dim j As Integer
For j = 1 To oPartsList.PartsListColumns.count
    If oPartsList.PartsListColumns(j).Title = "OBJEKT" Then Exit For
Next

If j > oPartsList.PartsListColumns.count Then
    MsgBox ("Spalte Objekt nicht gefunden. Abbruch")
    Exit Sub
End If

Dim i As Integer
For i = 1 To oPartsList.PartsListRows.count
    oPartsList.PartsListRows.Item(i).Visible = True
    If (oPartsList.PartsListRows.Item(i).Item("Objekt")) < 199 Then oPartsList.PartsListRows.Item(i).Visible = False
Next
 
Dim sPartsListSortString1 As String
sPartsListSortString1 = "ESM-Nr."
Call oPartsList.Sort(sPartsListSortString1, True)
     
'Call oPartsList.Renumber
       
Dim k As Integer
k = 200

For i = 1 To oPartsList.PartsListRows.count
    If oPartsList.PartsListRows.Item(i).Visible = True Then
        oPartsList.PartsListRows.Item(i).Item(j).Value = k
        k = k + 1
    End If
Next

'oPartsList.SaveItemOverridesToBOM

'For i = 1 To oPartsList.PartsListRows.count
    ' oPartslist.PartsListRows.Item(i).Visible = True
    'If (oPartslist.PartsListRows.Item(i).Item("Objekt")) > 199 Then oPartslist.PartsListRows.Item(i).Visible = True
'Next

End Sub

---

------------------
MfG
Ralf

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