Hallo Franz,
ich bekomme eine Fehlermeldung 1004 Anwendungs- oder objektdefinierter Fehler.
Das gesamte Script sieht bei mir jetzt so aus, nachdem ich den Zähler eingebaut habe:
Sub Daten_umgruppieren()
Dim wks As Worksheet
Dim Zeile As Long, Spalte 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 = "Date"
.Cells(1, 2).Value = "FINIS"
.Cells(1, 3).Value = "Desc 01"
.Cells(1, 4).Value = "Pack Stage 01"
.Cells(1, 5).Value = "Pack Resp 01"
.Cells(1, 6).Value = "Resp 01"
.Cells(1, 7).Value = "Pack Mat 01"
.Cells(1, 8).Value = "Time 01"
.Cells(1, 9).Value = "Mat cost 01"
.Cells(1, 10).Value = "Labour cost 01"
.Cells(1, 11).Value = "Total cost 01"
.Cells(1, 12).Value = "number Packs 01"
.Cells(1, 13).Value = "Packs 01"
.Cells(1, 14).Value = "Pack Stage 02"
.Cells(1, 15).Value = "Pack Resp 02"
.Cells(1, 16).Value = "Resp 02"
.Cells(1, 17).Value = "Pack Mat 02"
.Cells(1, 18).Value = "Time 02"
.Cells(1, 19).Value = "Mat cost 02"
.Cells(1, 20).Value = "Labour cost 02"
.Cells(1, 21).Value = "Total cost 02"
.Cells(1, 22).Value = "number Packs 02"
.Cells(1, 23).Value = "Packs 02"
.Cells(1, 24).Value = "Pack Stage 03"
.Cells(1, 25).Value = "Pack Resp 03"
.Cells(1, 26).Value = "Resp 03"
.Cells(1, 27).Value = "Pack Mat 03"
.Cells(1, 28).Value = "Time 03"
.Cells(1, 29).Value = "Mat cost 03"
.Cells(1, 30).Value = "Labour cost 03"
.Cells(1, 31).Value = "Total cost 03"
.Cells(1, 32).Value = "number Packs 03"
.Cells(1, 33).Value = "Packs 03"
.Cells(1, 34).Value = "Pack Stage 04"
.Cells(1, 35).Value = "Pack Resp 04"
.Cells(1, 36).Value = "Resp 04"
.Cells(1, 37).Value = "Pack Mat 04"
.Cells(1, 38).Value = "Time 04"
.Cells(1, 39).Value = "Mat cost 04"
.Cells(1, 40).Value = "Labour cost 04"
.Cells(1, 41).Value = "Total cost 04"
.Cells(1, 42).Value = "number Packs 04"
.Cells(1, 43).Value = "Packs 04"
SpaKey = 2 'Spalte mit den zu vergleichenden Werten
SpaWert1 = 4 'Spalte mit den zu übertragenden Werten
SpaWert2 = 5
SpaWert3 = 6
SpaWert4 = 7
SpaWert5 = 8
SpaWert6 = 9
SpaWert7 = 10
SpaWert8 = 11
SpaWert9 = 12
SpaWert10 = 13
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: Spalte = SpaWert
Else
Spalte = Spalte + 1
.Cells(Zeile1, Spalte).Value = _
.Cells(Zeile, SpaWert).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
viele Grüße Will