Liste umgruppieren
30.10.2012 11:08:12
Wilfied
leider kriege ich meinen alten Beitrag nicht mehr als noch offen deklariert, daher habe ich jetzt einen neuen aufgemacht, weil mir noch eine ganze Kleinigkeit fehlt.
ok.....
ich bin nun in der Evolutionsstufe etwas weiter gekommen und wende das Umgruppierungsmakro für 2 Fälle an.
das ursprüngliche Makro:
Sub Daten_umgruppieren()
Dim wks As Worksheet
Dim Zeile As Long, Zeile1 As Long, ZeileLetzte As Long, SpaKey As Long, SpaWert As Long
Dim sMsgTitel As String
Dim StatusCalc As Long
Dim varKey
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
sMsgTitel = "Daten in Zeilen umgruppieren"
On Error GoTo Fehler
Set wks = ActiveSheet 'oder = Worksheets("Tabelle1")
'Blatt mit Daten zum Umgruppieren kopieren
wks.Copy After:=wks
Set wks = ActiveSheet
With wks
'Titelzeile einfügen
.Rows(1).Insert
.Cells(1, 1).Value = "MyDate"
.Cells(1, 2).Value = "MyNumber"
.Cells(1, 3).Value = "Total Qty"
.Cells(1, 4).Value = "Spinst 01"
.Cells(1, 5).Value = "Time 01"
.Cells(1, 6).Value = "Mat cost 01"
.Cells(1, 7).Value = "Labour cost 01"
.Cells(1, 8).Value = "Total cost 01"
.Cells(1, 9).Value = "Spinst 02"
.Cells(1, 10).Value = "Time 02"
.Cells(1, 11).Value = "Mat cost 02"
.Cells(1, 12).Value = "Labour cost 02"
.Cells(1, 13).Value = "Total cost 02"
.Cells(1, 14).Value = "Spinst 03"
.Cells(1, 15).Value = "Time 03"
.Cells(1, 16).Value = "Mat cost 03"
.Cells(1, 17).Value = "Labour cost 03"
.Cells(1, 18).Value = "Total cost 03"
SpaKey = 2 'Spalte mit den zu vergleichenden Werten
SpaWert1 = 4 'Spalte mit den zu übertragenden Werten
SpaWert2 = 5
SpaWert3 = 6
SpaWert4 = 7
SpaWert5 = 8
ZeileLetzte = .Cells(.Rows.Count, SpaKey).End(xlUp).Row
If ZeileLetzte "" Then
If varKey .Cells(Zeile, SpaKey).Value Then
varKey = .Cells(Zeile, SpaKey).Value
Zeile1 = Zeile
Else
.Cells(Zeile1, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = _
.Cells(Zeile, SpaWert1).Value
.Cells(Zeile1, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = _
.Cells(Zeile, SpaWert2).Value
.Cells(Zeile1, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = _
.Cells(Zeile, SpaWert3).Value
.Cells(Zeile1, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = _
.Cells(Zeile, SpaWert4).Value
.Cells(Zeile1, .Columns.Count).End(xlToLeft).Offset(0, 1).Value = _
.Cells(Zeile, SpaWert5).Value
.Rows(Zeile).ClearContents
End If
Else
.Rows(Zeile).ClearContents
End If
Next
'Leere Zeilen löschen
With .Range(.Cells(1, SpaKey), .Cells(ZeileLetzte, SpaKey))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
End With
.Columns.AutoFit
'Fehlerbehandlung
Fehler:
With Err
Select Case .Number
Case 0 'kein Fehler
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, vbOKOnly, sMsgTitel
End Select
End With
Beenden:
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End If
End With
End Sub
das einzige Thema was ich jetzt noch habe ist, dass das Makro das Ergebnis in ein vorhandenes Tabellenblatt schreiben soll, was "Ergebnis" heißt.
Im Moment generiert es immer eine Kopie des Originalblattes und hängt (2) dahinter. Ist dieses Blatt schon vorhanden macht das Makro (3).
Ich muss die Ergebnisse aber über einen Sverweis weiter verarbeiten, den ich gerne in einem dritten Blatt schon vordefinieren möchte, was mir aber nicht gelingt wenn ich den Blattnamen nicht schon habe.
sorry für das doppelte posting, Will