Hallo zusammen :-)
Was ich habe:
Eine Mess-Software erzeugt eine Tabelle mit verschiedenen Spalten, alles Messwerte zu bestimmten Stoffen. Das sieht dann bspw so aus:
Spalte 1 # Spalte 2 # Spalte 3 # Spalte 4 # Spalte 5
Cu # Ti # Ni # Mn # Cr
Weiterhin habe ich eine Liste aller möglichen zu messenden Stoffe, d.h. alles was theoretisch aus meinem Messprogramm rauskommen kann.
Was ich suche:
Meine Mess-Software erzeugt nun immer nur die Stoffe die auch gemessen wurden. Zwar schaffe ich es diese Spalten in gewünschter Reihenfolge zu sortieren jedoch möchte ich dass bspw die "Ti"-Spalte IMMER die 7te Spalte ist. Egal ob da nun 1 oder 10 andere Spalten von meinem Messprogramm kamen.
Was mein Skript also tun sollte:
Vergleich mit "Soll-Liste" ob das erste Element (hier könnte das bspw. "AL" sein) in den Messergebnissen dabei ist.
Wenn ja, dann in erste Spalte verschieben
Wenn nein, dann neue erste Spalte einfügen mit Überschrift "AL"
Dann Vergleich mit "Soll-Liste" ob das zweite Element (hier könnte das bspw. "Cr" sein) in den Messergebnissen dabei ist.
Wenn ja, dann in erste Spalte verschieben
Wenn nein, dann neue erste Spalte einfügen mit Überschrift "Cr"
Hier ist mein Code der bisher "nur" die Spalten in der gewünschten Reihenfolge sortiert jedoch NICHT fehlende Elemente einfügt:
Sub ElementeAnordnen()
Dim arrColOrder As Variant, ndx As Integer
Dim Found As Range, counter As Integer
'Meine insgesamt vorhandenen Elemente in gewünschter Reihenfolge
arrColOrder = Array("Al", "Cr", "Cu", "Mn", "Mo", "Ti")
counter = 1
Application.ScreenUpdating = False
For ndx = LBound(arrColOrder) To UBound(arrColOrder)
' Sucht nur in Zeile 20 nach den Werten aus dem oberen Array
' Alles andere wird in der bestehenden Reihenfolge rechts daneben stehengelassen
Set Found = Rows("20:20").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not Found Is Nothing Then
If Found.Column <> counter Then
Found.EntireColumn.Cut
Columns(counter).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next ndx
Application.ScreenUpdating = True
End Sub
|