AW: nochmal hilfe
27.06.2011 09:01:15
Dirk
Hallo Burkhard,
kopiere dieses Makro in Dein Tabellenblatt 'Tagesdaten'
Private Sub Worksheet_Activate()
'Tabelleneintraegeaktualisieren
Dim SourceSh As Worksheet, TargetSh As Worksheet, MyFind As Range
Dim FirstRow As Long, LastRow As Long, CalDays As Long, MaschAnz As Long
Dim i As Long, k As Long, DayRow As Long, DayName As String, DayCol As Long
Dim TargetRow As Long, EmptySh As Boolean, Cell As Object
CalDays = 6 'Sonntag is arbeitsfrei und wird nicht beruecksichtigt. Falls doch, Wert auf 7 _
hochsetzen
DayRow = 4
Set SourceSh = Sheets("Auslastung Fertigung") 'Ursprungsblatt der Daten setzen
Set TargetSh = ActiveSheet 'Zielblatt fuer die Daten setzen
EmptySh = False
With SourceSh
'Erste Datenzeile finden
With .Range("A:A")
Set MyFind = .Find(what:="Maschine", LookIn:=xlValues, lookat:=xlWhole)
If Not MyFind Is Nothing Then
FirstRow = MyFind.Offset(1, 0).Row
Else
MsgBox "Spaltenbezeichnung 'Maschine' im Blatt '" & SourceSh.Name & "' konnte _
nicht gefunden werden." & vbCrLf & _
"Blatt '" & TargetSh.Name & "' kann nicht aktualisiert werden! Bitte _
Schreibweise und Blattnamen pruefen", 48, "Fehler"
Exit Sub
End If
Set MyFind = Nothing
Set MyFind = .Find(what:="Anzahl", LookIn:=xlValues, lookat:=xlWhole)
If Not MyFind Is Nothing Then
LastRow = MyFind.Offset(-1, 0).Row
Else
MsgBox "Zelleintrag 'Anzahl' im Blatt '" & SourceSh.Name & "' konnte nicht _
gefunden werden." & vbCrLf & _
"Blatt '" & TargetSh.Name & "' kann nicht aktualisiert werden! Bitte _
Schreibweise und Blattnamen pruefen", 48, "Fehler"
Exit Sub
End If
Set MyFind = Nothing
End With
End With
MaschAnz = LastRow - (FirstRow - 1)
Application.Calculation = xlManual
For i = FirstRow To LastRow 'Schleife ueber all Maschinen
For k = 1 To CalDays 'Schleife ueber all Kalendertage
'Dayname ableiten
Select Case k
Case 1
DayName = "Mo"
Case 2
DayName = "Di"
Case 3
DayName = "Mi"
Case 4
DayName = "Do"
Case 5
DayName = "Fr"
Case 6
DayName = "Sa"
Case 7
DayName = "So"
End Select
'finde ersten wochentag in Tageszeile
With SourceSh.Rows(DayRow)
For Each Cell In .Cells
If Cell.Value = DayName Then
DayCol = Cell.Column 'setze erste Spalte der Tagesdaten
GoTo exit_sub
End If
Next Cell
If Cell.Column = 256 Then
MsgBox "Zelleintrag '" & DayName & "' im Blatt '" & SourceSh.Name & "' konnte _
nicht gefunden werden." & vbCrLf & _
"Blatt '" & TargetSh.Name & "' kann nicht aktualisiert werden! Bitte _
Schreibweise und Blattnamen pruefen", 48, "Fehler"
Exit Sub
End If
If EmptySh = False Then
GoSub Empty_sheet
End If
'Schreibe Daten in TargetSh
With TargetSh
.Cells(TargetRow, 3) = SourceSh.Cells(5, DayCol) 'Datum
.Cells(TargetRow, 4) = SourceSh.Cells(i, 1).Value 'Maschine
.Cells(TargetRow, 6) = SourceSh.Cells(i, DayCol).Value 'Anzahl Schichten
.Cells(TargetRow, 7) = SourceSh.Cells(i, DayCol + 1).Value 'Soll Stueckzahl 3 _
Tage
.Cells(TargetRow, 8) = SourceSh.Cells(i, DayCol + 2).Value 'Soll Stueckzahl
.Cells(TargetRow, 9) = SourceSh.Cells(i, DayCol + 3).Value 'Ist-Stueckzahl
TargetRow = TargetRow + 1
End With
End With
Next k
Next i
GoTo exit_sub
Empty_sheet:
'pruefe ob daten in TaregtSh enthalten sind
If TargetSh.Range("A65536").End(xlUp).Row = 1 Then
'Tabelle ist leer, neu anlegen
Else
'Tabelle enthaelt daten, leere Tabelle und schreibe neu
TargetSh.Range("A2:K65536").Delete
End If
TargetRow = 2
EmptySh = True
Return::
exit_sub:
Application.Calculation = xlAutomatic
End Sub
Lass' hoeren, ob ok.
Gruss
Dirk aus Dubai