Werte per Makro sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Uebertragen() Dim lngQ As Long, lngZ As Long, zz As Long, intZ As Integer Dim lngA As Long, intM As Integer Sheets("IST").Select lngQ = Cells(Rows.Count, 1).End(xlUp).Row lngZ = 1 With Sheets("SOLL") .Range(.Cells(1, 1), .Cells(1, 8)) = Range(Cells(1, 1), Cells(1, 8)).Value For zz = 2 To lngQ If lngA <> Cells(zz, 1) Then lngA = Cells(zz, 1) lngZ = lngZ + 1 .Cells(lngZ, 1) = lngA intZ = 2 Else intZ = intZ + 7 If intM < intZ Then intM = intZ End If .Range(.Cells(lngZ, intZ), .Cells(lngZ, intZ + 6)) = _ Range(Cells(zz, 2), Cells(zz, 8)).Value Next zz For intZ = 9 To intM Step 7 .Range(.Cells(1, intZ), .Cells(1, intZ + 6)) = _ Range(Cells(1, 2), Cells(1, 8)).Value Next intZ .Select End With End Sub

Hallo Paul,
zwischen den beiden Mappen, die du hochgeladen hast, gibt es einige heftige Unterschiede:
In der ersten Mappe (42155.xls) stehen in Spalte A Zahlen, ohne leere Zellen,
dafür mit mehrfach untereinander stehenden identischen Werten, z. B.
1000111
1000111
1100234
1100234
Für Tabellen mit dieser Struktur laufen die beiden von mir vorgeschlagenen Prozeduren.
Hast du sie in der von dir als 42155.xls hochgeladenen Mappe denn überhaupt getestet???
In der zweiten Mappe (42172.xls) stehen in Spalte A Texte, mit leeren Zellen,
ohne mehrfach untereinander stehende identische Werte, z. B.
13_1
(leer)
14_1
(leer)
(leer)
15_1
Das bedeutet wohl, dass alle Zeilen mit leerer Spalte A zur jeweils letzten
in Spalte A stehenden "Nummer" gehören sollen.
Außerdem enthält die zweite Mappe Gruppen mit so vielen IST-Zeilen, dass sie in SOLL nicht in eine Zeile passen.
Es gibt eben (vor Excel-Version 2007) nur 256 Spalten...
In diesem Fall muss eine Gruppe in mehreren SOLL-Zeilen wiedergegeben werden.
Das sind die Gruppen mit 11_1, 40_2 und 51_1 in Spalte A.
Für die zweite Datei habe ich die Prozedur abgewandelt zu


Sub Uebertragen3()
Dim zZ As Long, zQ As Long, sZ As Integer, strA As String, intM As Integer
Sheets("IST").Select
zZ = 1
With Sheets("SOLL")
.Cells.ClearContents
.Cells(1, 1).Resize(, 8) = Cells(1, 1).Resize(, 8).Value
For zQ = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(zQ, 1) > "" Or sZ >= 247 Then
If Cells(zQ, 1) > "" Then strA = Cells(zQ, 1)
zZ = zZ + 1:            .Cells(zZ, 1) = strA
sZ = 2
Else
sZ = sZ + 7:            If intM < sZ Then intM = sZ
End If
.Cells(zZ, sZ).Resize(, 7) = Cells(zQ, 2).Resize(, 7).Value
Next zQ
For sZ = 9 To intM Step 7
.Cells(1, sZ).Resize(, 7) = Cells(1, 2).Resize(, 7).Value
Next sZ
.Select
End With
End Sub

Noch eine Bemerkung: Spaltenüberschriften sollten in Zeile 1 über allen benutzten Spalten stehen.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Hallo Erich,
vielen Dank für die Änderung. Ich dachte nicht, daß diese Unterschiede so gravierend sind - ich bin eben wirklich blutiger VBA-Laie!
Natürlich habe ich Deine ersten beiden Vorschläge ausprobiert, allerdings die Makros nicht zum Laufen gebracht.
Das jetzige funktioniert, allerdings noch nicht so, wie es sollte.
Dein jetziger Vorschlag sieht aber echt gut aus, hat aber noch diesen Schönheitsfehler. Es werden nur die Spalten B bis H übertragen, und nicht, wie in Tabelle "IST" vorgegeben, bis Spalte Q. Kann man diese Einstellung dynmaisch machen? Es gibt eben auch Dateien, die wirklich nur bis G oder J gehen.
Es ist übrigens durchaus akzeptabel, wenn nach 256 Spalten einfach abgeschnitten wird.
Du hast Excel 2007 erwähnt, wieviele Spalten gibt es denn hier? Wird wohl Zeit für mich zu wechseln.
Nochmals vielen Dank für Deine wertvolle Hilfe, ich hänge Dir die Datei mit dem Makro nochamls an.
https://www.herber.de/bbs/user/42175.zip
Viele Grüße
Paul

Option Explicit Sub Uebertragen4() Dim zZ As Long, zQ As Long, sZ As Integer, strA As String, intM As Integer Dim intC As Integer Sheets("IST").Select intC = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column - 1 zZ = 1 With Sheets("SOLL") .Cells.ClearContents .Cells(1, 1).Resize(, intC + 1) = Cells(1, 1).Resize(, intC + 1).Value For zQ = 2 To Cells(Rows.Count, 2).End(xlUp).Row If Cells(zQ, 1) > "" Or sZ >= 256 - 2 * intC Then If Cells(zQ, 1) > "" Then strA = Cells(zQ, 1) zZ = zZ + 1: .Cells(zZ, 1) = strA sZ = 2 Else sZ = sZ + intC: If intM < sZ Then intM = sZ End If .Cells(zZ, sZ).Resize(, intC) = Cells(zQ, 2).Resize(, intC).Value Next zQ For sZ = intC + 2 To intM Step intC .Cells(1, sZ).Resize(, intC) = Cells(1, 2).Resize(, intC).Value Next sZ .Select End With End Sub

Option Explicit Sub Uebertragen2() Dim zZ As Long, zQ As Long, sZ As Integer, lngA As Long, intM As Integer Sheets("IST").Select zZ = 1 With Sheets("SOLL") .Cells.ClearContents .Cells(1, 1).Resize(, 8) = Cells(1, 1).Resize(, 8).Value For zQ = 2 To Cells(Rows.Count, 1).End(xlUp).Row If lngA <> Cells(zQ, 1) Then lngA = Cells(zQ, 1) zZ = zZ + 1: .Cells(zZ, 1) = lngA sZ = 2 Else sZ = sZ + 7: If intM < sZ Then intM = sZ End If .Cells(zZ, sZ).Resize(, 7) = Cells(zQ, 2).Resize(, 7).Value Next zQ For sZ = 9 To intM Step 7 .Cells(1, sZ).Resize(, 7) = Cells(1, 2).Resize(, 7).Value Next sZ .Select End With End Sub

Beliebteste Forumthreads (12 Monate)

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