---

Mahlzeit Miteinander,

ich muss euch leider schon wieder stören  

Bin gerade daran ein zweidimensionales Array nach einer Spalte zu ordnen und dieses dann nach Excel zu schieben. Ich habe jetzt ewig nach einer für mich verständlichen Art und Weise für eine Sortierung gesucht und nun auch eine im Internet gefunden die funktioniert.
Jetzt habe ich aber meiner Meinung nach ein grundlegendes Problem. Und zwar wird diese Sortierung intern mit Private Subs angesprochen und läuft dann je nach Anwenderwusch eine unbestimmte Anzahl an Durchläufen durch. Ich komme nicht darauf den richtigen Ort für meine Excel-Export Zeilen zu finden.

Das Array sieht so aus...

Querschnitt|Name
2786            Fill.1
2611            Fill.2
2800            Fill.1
.                  .
.                  .
.                  .

... und soll nach der ersten Spalte sortiert werden.

Habe euch mal den kompletten Code angehängt, inklusive den Export-Zeilen am Ende.

Hat jemand vielleicht einen Denkanstoß für mich ?

Code:

---

Option Explicit

Public Sub prcTest()

Dim documents1 As Documents
Set documents1 = CATIA.Documents

Dim partDocument1 As PartDocument
Set partDocument1 = documents1.Item("Kabelkanal.CATPart")

Dim part1 As Part
Set part1 = partDocument1.Part

Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory

Dim hybridBodies1 As HybridBodies
Set hybridBodies1 = part1.HybridBodies

Dim TheSpaWorkbench As Workbench

Set TheSpaWorkbench = CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")

Dim intColumn As Integer
Dim lngRow As Long

Dim vntSortArray As Variant

'die zu sortierenden Spalten
'negative Zahl = Spalte absteigend sortieren
'positive Zahl = Spalte aufsteigend sortieren
vntSortArray = Array(1)

'Selection starten und nach allen Fills suchen------------------------------------------------------------

Dim selection01 As Selection
Set selection01 = CATIA.ActiveDocument.Selection
selection01.Search ".Fill.name=Fill*;all"
Dim E As Long
E = selection01.Count2

  ReDim flaecheArray(1 To E, 1 To 2)
 
'E zur Info und als Max-Wert für die Schleife-------------------------------------------------------------

'flaecheArray befüllen mit Fläche (gerundet) und Namen der einzelnen Flächen -----------------------------
Dim Wert
Dim Referenz
Dim Measurable01

Dim I As Long
For I = E To 1 Step -1

  Set Wert = selection01.Item(I).Value
  Set Referenz = part1.CreateReferenceFromObject(Wert)
  Set Measurable01 = TheSpaWorkbench.GetMeasurable(Referenz)

flaecheArray(I, 1) = Measurable01.Area
flaecheArray(I, 1) = Round(flaecheArray(I, 1), 6) * 1000000
flaecheArray(I, 2) = Wert.Name
Next
part1.Update

'Sortierroutine starten

Call prcSort(vntSortArray, flaecheArray())

'Ausgabe Testarray
Application.ScreenUpdating = False
' Range("A1:A10000").Value = flaecheArray
Application.ScreenUpdating = True

End Sub

Private Sub prcSort(vntSortArray As Variant, flaecheArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long, lngRowsArray() As Long
Dim lngRowsCount As Long, lngRangeCount As Long
Dim vntTemp As Variant
ReDim lngRowsArray(0 To 1, 0 To UBound(flaecheArray) * 2)

'Array für den 1. Sortierlauf
lngRowsArray(0, 0) = LBound(flaecheArray)
lngRowsArray(0, 1) = UBound(flaecheArray)
lngRowsCount = 1

For intIndex = LBound(vntSortArray) To UBound(vntSortArray)

  'Wenn eine Spalte angegeben
  If vntSortArray(intIndex) <> 0 Then
   lngRangeCount = -1

   'Schleife zum sortieren der einzelnen Bereiche
   For lngIndex1 = 0 To lngRowsCount Step 2

    'Sortieren des Bereichs, wenn Zeilenzahl größer 1
    If lngRowsArray(0, lngIndex1) <> lngRowsArray(0, lngIndex1 + 1) Then

     Call prcQuickSort(CLng(lngRowsArray(0, lngIndex1)), _
      CLng(lngRowsArray(0, lngIndex1 + 1)), CInt(Abs(vntSortArray(intIndex))), _
      CBool(vntSortArray(intIndex) > 0), flaecheArray())

     'sortierten Bereich merken
     lngRangeCount = lngRangeCount + 2
     lngRowsArray(1, lngRangeCount - 1) = lngRowsArray(0, lngIndex1)
     lngRowsArray(1, lngRangeCount) = lngRowsArray(0, lngIndex1 + 1)

    End If
   Next
   
   lngRowsCount = -1

   'Durchsuchen der soeben sortierten Spalte nach Wertewechsel
   For lngIndex1 = 0 To lngRangeCount Step 2

    '1. Zeile des zu sortierenden Bereichs
    vntTemp = flaecheArray(lngRowsArray(1, lngIndex1), Abs(vntSortArray(intIndex)))
    lngRowsCount = lngRowsCount + 1
    lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1)

    'Suche nach Wechsel innerhalb des Bereichs
    For lngIndex2 = lngRowsArray(1, lngIndex1) To lngRowsArray(1, lngIndex1 + 1)
     If vntTemp <> flaecheArray(lngIndex2, Abs(vntSortArray(intIndex))) Then
      lngRowsCount = lngRowsCount + 2
      lngRowsArray(0, lngRowsCount - 1) = lngIndex2 - 1
      lngRowsArray(0, lngRowsCount) = lngIndex2
      vntTemp = flaecheArray(lngIndex2, Abs(vntSortArray(intIndex)))
     End If
    Next

    'letzte Zeile des zu sortierenden Bereichs
    lngRowsCount = lngRowsCount + 1
    lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1 + 1)

   Next
  End If
Next
End Sub

Private Sub prcQuickSort(lngLbound As Long, lngUbound As Long, _
intSortColumn As Integer, bntSortKey As Boolean, flaecheArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntTemp As Variant, vntBuffer As Variant
lngIndex1 = lngLbound
lngIndex2 = lngUbound
vntBuffer = flaecheArray((lngLbound + lngUbound) \ 2, intSortColumn)
Do
  If bntSortKey Then
   Do While flaecheArray(lngIndex1, intSortColumn) < vntBuffer
    lngIndex1 = lngIndex1 + 1
   Loop
   Do While vntBuffer < flaecheArray(lngIndex2, intSortColumn)
    lngIndex2 = lngIndex2 - 1
   Loop
  Else
   Do While flaecheArray(lngIndex1, intSortColumn) > vntBuffer
    lngIndex1 = lngIndex1 + 1
   Loop
   Do While vntBuffer > flaecheArray(lngIndex2, intSortColumn)
    lngIndex2 = lngIndex2 - 1
   Loop
  End If
  If lngIndex1 < lngIndex2 Then
   If flaecheArray(lngIndex1, intSortColumn) <> _
    flaecheArray(lngIndex2, intSortColumn) Then
    For intIndex = LBound(flaecheArray, 2) To UBound(flaecheArray, 2)
     vntTemp = flaecheArray(lngIndex1, intIndex)
     flaecheArray(lngIndex1, intIndex) = _
      flaecheArray(lngIndex2, intIndex)
     flaecheArray(lngIndex2, intIndex) = vntTemp
    Next
   End If
   lngIndex1 = lngIndex1 + 1
   lngIndex2 = lngIndex2 - 1
  ElseIf lngIndex1 = lngIndex2 Then
   lngIndex1 = lngIndex1 + 1
   lngIndex2 = lngIndex2 - 1
  End If
Loop Until lngIndex1 > lngIndex2
If lngLbound < lngIndex2 Then Call prcQuickSort(lngLbound, _
  lngIndex2, intSortColumn, bntSortKey, flaecheArray())
If lngIndex1 < lngUbound Then Call prcQuickSort(lngIndex1, _
  lngUbound, intSortColumn, bntSortKey, flaecheArray())
 
End Sub

Sub Excel1()

On Error Resume Next
Dim Excel As Object
Set Excel = GetObject(, "EXCEL.Application")

'Bevor Excel geöffnet wird, muss es geschlossen sein !!! -------------------------------------------------

If Err.Number <> 0 Then
            Err.Clear
            Set Excel = CreateObject("Excel.Application")
Else
            Err.Clear
            MsgBox "Please note you have to close Excel", vbCritical
            Exit Sub
End If

' Alle Objekte für Excel deklarieren ---------------------------------------------------------------------

Dim workbooks As workbooks
Dim workbook As workbook
Dim Sheets As Object
Dim Sheet As Object
Dim worksheet As Excel.worksheet
Dim myworkbook As Excel.workbook
Dim myworksheet As Excel.worksheet

Set workbooks = Excel.Applcation.workbooks
Set myworkbook = Excel.workbooks.Add
Set myworksheet = Excel.ActiveWorkbook.Add

Dim partDoc As Object
Set partDoc = CATIA.ActiveDocument.Part
Dim docname As String
docname = partDoc.Name

Dim objSPAWkb
Set objSPAWkb = CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")

Excel.Visible = True

'Formatierung der Ersten Zeilen --------------------------------------------------------------------------

Excel.Range("A:A").ColumnWidth = 15
Excel.Range("B:B").ColumnWidth = 15

Excel.Range("A:B").Font.Name = "Arial"
Excel.Range("A:B").Font.Size = 20

'Formatierung der Ersten Zellen --------------------------------------------------------------------------

Excel.Range("1:1").Font.Bold = True
Excel.Range("1:1").RowHeight = 20
Excel.Range("1:1").Font.Size = 12

'Befüllung Reihe Eins ------------------------------------------------------------------------------------

Excel.Cells(1, 1) = "Name"
Excel.Cells(1, 2) = "Querschnitt"

'Befüllung ab Reihe Zwei ---------------------------------------------------------------------------------

Excel.Range(Cells(2, 1), Cells(E, 2)) = flaecheArray

End Sub

---

Viele Grüße
Micha

[Diese Nachricht wurde von MichaX am 11. Apr. 2017 editiert.]

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

---

Servus Micha
Hast du noch den Link woher du den ursprünglichen Code her hast? ggf gibt es dort ein Beispiel.
Welchen Grund hat es dass du den Code verändert hast (nicht passende Variablennamen)?
Da du deinen Array per ByRef übergeben hast, müsste der Array ja durch die Subroutine verändert worden sein, und du kannst nach dem Durchlauf den Array direkt ein deinen Export weitergeben. (per Input der Sub oder globale Variable)

Gruß
Bernd

PS: Schalte "On Error resume next" aus sobald du es nicht mehrt benötigst (dann hättest du auch eine Fehlermeldung bekommen)

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

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

---

Hallo Bernd,

ja klar, hier ist die Quelle der Sortierung:

http://www.online-excel.de/excel/singsel_vba.php?f=97

Ja genau, so würde ich es auch gerne machen, nur bin ich mir unsicher an welcher Stelle ich dann die Sub Excel() einbauen muss.

Wenn ich ganz am Ende meines Codes den Call Befehl setze, bekomme ich keine Werte in die Exceltabelle.
Werde jetzt gleich mal On Error resume next rausnehmen und parallel weiterschauen ob ich noch Fehler finde.

Gruß Micha

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

---

Servus
Du könntest doch einfach den Array übergeben (siehe hier) zB

Code:

---

Sub Excel1(MyArrayToExport() as Variant)
......

---

und dem Aufruf über

Code:

---

Call Excel1(flaecheArray)

---

Schau dir auch mal die Sichtbarkeit/Verfügbarkeit von Variablen/Objekten in verschiedenen Routinen/Funktionen an.

Gruß
Bernd

PS: Das "On error resume next" war da für ein paar Zeilen sinnvoll, du solltest die Fehlerbehandlung nur wieder einschalten.

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

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

---

Vielen Dank Bernd,

habe nun auch meinen Fehler gefunden. Ich muss die Laufvariable E auch noch in die Sub Excel1 übergeben.
Sonst kann das Programm ja nicht riechen wie es die Zellen befüllen soll.

Jetzt habe ich noch eine dumme Frage...
Wie schalte ich On Error resume next eigentlich wieder aus ?

Tausend Dank für die immer wieder  tolle Hilfe !!!

Grüße
Micha

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

---

Servus
Zur Fehlbehandlung: siehe zB hier.
Warum E übergeben? Es gibt doch UBound und LBound. Dann wird dein Code auch etwas universaler.

Gruß
Bernd

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

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

---

Guten Morgen,

da hast du natürlich Recht, Danke !

viele Grüße
Micha

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