Spaltenreihenfolge prüfen, gegebenenf. umsortieren

Hallo zusammen,
nur mal eine Frage wie man sowas per VBA macht.
Je nach Exportformat aus SAP verschieben sich die angezeigten Spalten einer Liste. Da mein Makro nur funktioniert, wenn die Liste in korrekter Spaltenreihenfolge vorliegt, wollte ich diese Prüfung noch voranstellen und gegebenenfalls die Liste in die richtige Spaltenreihenfolge umsortieren.
Hab mir das irgendwie so vorgestellt:
Zuerst im Makro die korrekte Reihenfolge mit der konkreten Überschrift definieren und prüfen, also bspw.:
Spalte A = Überschrift A
Spalte B = Überschrift B
Spalte C = Überschrift C
Spalte D = Überschrift D
Spalte E = Überschrift E
Liegen diese Überschriften der Listet in einer anderen Reihenfolge vor, soll nach obiger sortiert werden.
Schön wäre noch, wenn eine Fehlermeldung erscheint, sollten Spaltenüberschriften in der Liste vorhanden sein, welche oben nicht definiert sind.
Und nun eben die Frage wie man sowas am geschicktesten in VBA realisiert.
Kann mir da wer helfen, wie man sowas variabel per VBA realisieren kann.
Vielen Dank vorab. Gruß Bernd

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub colTest() Dim nurDie, welche As Range, c As Range, dorthin&(), i, fehler As Boolean, fehler2 As Boolean nurDie = Array("ÜberschriftA", "ÜberschriftB", "ÜberschriftC", "ÜberschriftD", "ÜberschriftE") ReDim dorthin(1 To UBound(nurDie) + 1) ' ab 1 = Spaltennummer Set welche = Intersect(Range("1:1"), ActiveSheet.UsedRange) For Each c In welche i = Application.Match(c.Value, nurDie, 0) If IsNumeric(i) Then dorthin(i) = c.Column _ Else MsgBox c.Value & " nicht in nurDie enthalten.": fehler = True Next For i = 1 To UBound(dorthin) If dorthin(i) = 0 Then MsgBox nurDie(i - 1) & " nicht belegt.": fehler2 = True Next If fehler Then MsgBox "Fehler: was tun?" ' *** der Fehler kann toleriert werden If fehler2 Then MsgBox "Fehler2: was tun?": Exit Sub ' *** dieser nicht. ' Das Blatt "Temp" muß existieren... For i = 1 To UBound(dorthin) ActiveSheet.Columns(dorthin(i)).Copy Sheets("Temp").Columns(i) Next End Sub

Hallo zusammen,
so, ein wenig getestet. Funktioniert eigentlich auch bestens... Eine Rückfrage trotzdem noch:
Im Normalfall ist ja die Liste korrekt, somit wäre also auch die ganze Kopiererei überflüssig.
Kann man das noch irgendwie vorher prüfen?
Dass dann praktisch nur kopiert wird, wenn es auch zu Verschiebungen zur Vorgabe kommt?
Folgend der auf meine Bedürfnisse angepaßte Teil:

Dim nurDie, welche As Range, c As Range, dorthin&(), i, fehler As Boolean, fehler2 As Boolean
aktName = ActiveSheet.name
'Prüfung, ob alle benötiten Spalten vorhanden sind - je nach Übergabeformat werden diese in die
'für die Aufbereitung benötigte Spaltenreihenfolge gebracht
'PersNr
'Nachname Vorname
'StammKST
'SenderKST
'KST-BAB
'LA man.
'LA-Kurztext
'Dauer/Std.
'Bemerk.APL-Wechsel
nurDie = Array("PersNr", "Nachname Vorname", "StammKST", "SenderKST", "KST-BAB", "LA man.", "LA- _
Kurztext", "Dauer/Std.", "Bemerk.APL-Wechsel")
ReDim dorthin(1 To UBound(nurDie) + 1) ' ab 1 = Spaltennummer
Set welche = Intersect(Range("1:1"), ActiveSheet.UsedRange)
For Each c In welche
i = Application.Match(c.Value, nurDie, 0)
If IsNumeric(i) Then dorthin(i) = c.Column _
Else MsgBox c.Value & " nicht in nurDie enthalten.": fehler = True
Next
For i = 1 To UBound(dorthin)
If dorthin(i) = 0 Then MsgBox nurDie(i - 1) & " nicht belegt.": fehler2 = True
Next
If fehler Then MsgBox "Fehler: was tun?"   ' *** der Fehler kann toleriert werden
If fehler2 Then MsgBox "Fehler2: was tun?": Exit Sub ' *** dieser nicht.
Sheets.Add(After:=Sheets(Sheets.Count)).name = "temp"
Sheets(aktName).Activate
' Das Blatt "Temp" muß existieren...
For i = 1 To UBound(dorthin)
ActiveSheet.Columns(dorthin(i)).Copy Sheets("Temp").Columns(i)
Next
Application.DisplayAlerts = False
Sheets(aktName).Delete
Application.DisplayAlerts = True
ActiveSheet.name = aktName

Vielen Dank vorab. Gruß Bernd

Option Explicit Sub colTest() Dim nurDie, welche As Range, c As Range, dorthin&(), i, fehler As Boolean, fehler2 As Boolean Dim ok As Boolean nurDie = Array("ÜberschriftA", "ÜberschriftB", "ÜberschriftC", "ÜberschriftD", "ÜberschriftE") ReDim dorthin(1 To UBound(nurDie) + 1) ' ab 1 = Spaltennummer Set welche = Intersect(Range("1:1"), ActiveSheet.UsedRange) For Each c In welche i = Application.Match(c.Value, nurDie, 0) If IsNumeric(i) Then dorthin(i) = c.Column _ Else MsgBox c.Value & " nicht in nurDie enthalten.": fehler = True Next ok = True For i = 1 To UBound(dorthin) If dorthin(i) = 0 Then MsgBox nurDie(i - 1) & " nicht belegt.": fehler2 = True ElseIf dorthin(i) <> i Then ok = False End If Next If ok And Not fehler Then MsgBox "Alle Spalten stimmen überein.": Exit Sub If fehler Then MsgBox "Fehler: was tun?" ' *** der Fehler kann toleriert werden If fehler2 Then MsgBox "Fehler2: was tun?": Exit Sub ' *** dieser nicht. ' Das Blatt "Temp" muß existieren... ' Sheets("Temp").Cells.Clear ggf. Kommentarzeichen entfernen For i = 1 To UBound(dorthin) ActiveSheet.Columns(dorthin(i)).Copy Sheets("Temp").Columns(i) Next End Sub

Sub Sortieren_Spalte() Dim LR As Integer, TB With ActiveSheet LR = .Cells(.Rows.Count, "A").End(xlUp).Row Set TB = Sheets.Add(after:=Sheets(Sheets.Count)) .Cells(1, 1).CurrentRegion.Copy TB.Cells(1, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True With TB .Sort.SortFields.Clear .Sort.SortFields.Add Key:=TB.Range("A:A"), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SetRange .Cells(1, 1).CurrentRegion .Sort.Header = xlNo .Sort.MatchCase = False .Sort.Orientation = xlTopToBottom .Sort.SortMethod = xlPinYin .Sort.Apply End With TB.Cells(1, 1).CurrentRegion.Copy .Cells(1, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=True End With With Application .DisplayAlerts = False TB.Delete .CutCopyMode = False .DisplayAlerts = True End With End Sub

Beliebteste Forumthreads (12 Monate)

Spaltenreihenfolge prüfen, gegebenenf. umsortieren

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread