AW: actice cell setzen
06.05.2004 12:57:53
Harald
Hallo Martin,
vielen Dank. Läuft super.
Apropos gesträubte Haare. Hier mein Code für die Vorderachsauswertung( Hinterachse ist 3mal so lang).
Eigentlich zum Weglaufen. Nix für Freunde des guten Geschmacks.
Sub DateiOeffnenFS()
'Beschleuniger
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'setzt gleiche Zelle in den Schichtblättern
Call Aktivieren
'öffnet Vorderachsdatei für Datum der aktiven Zelle
Dim Filename As String
Filename = "I:\NIO_Zahlen\FS\NIO_FS" & Format(ActiveCell, "yyyy") & Format(ActiveCell, "mm") & Format(ActiveCell, "dd") & ".xls"
If Dir(Filename) = "" Then
MsgBox "Gesuchte Datei wurde nicht gefunden."
Exit Sub
Else
Workbooks.Open Filename
End If
'löschen falscher Datums- und Schichtzeilen
Dim d As Range, txt As String
For Each d In Worksheets(1).Range("A2:A8")
txt = d.Text + ".xls"
If txt <> Right(ActiveWorkbook.Name, 12) Then
d.EntireRow.ClearContents
End If
Next d
For i = 2 To 8
If Cells(i, 2) < 1 Then Cells(i, 2).EntireRow.ClearContents
Next i
For e = 2 To 8
If Cells(e, 2) > 3 Then Cells(e, 2).EntireRow.ClearContents
Next e
For f = 2 To 8
If Cells(f, 3) <> 1 Then Cells(f, 3).EntireRow.ClearContents
Next f
Rows("2:9").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Auswerten
Range("C10:C12").Cut Destination:=Range("C2:C4")
Range("T:U,CO:DD").Delete Shift:=xlToLeft
Range("AG2").FormulaR1C1 = "=VALUE(LEFT(RC[51],3))"
Range("AG2").Select
Selection.Copy
Range("AG2:AS4").Select
ActiveSheet.Paste
Range("C2:AS2").Copy
'Wechseln
Windows("Pareto_Analyse_05_04.xls").Activate
'fügt die kopierten Teilergebnisse ein und setzt aktive Zelle einen Tag weiter
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(-1, 1).Select 'VOA
'Blattwechsel und NIO_Datei aktivieren
Call namesFS
'Schicht 2 markieren
Range("C3:AS3").Select
Selection.Copy
Windows("Pareto_Analyse_05_04.xls").Activate
' fügt die kopierten Teilergebnisse ein und setzt aktive Zelle einen Tag weiter
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(-1, 1).Select 'VOA
'Blattwechsel und NIO_Datei aktivieren
Call namesFS
'Schicht 3 markieren
Range("C4:AS4").Select
Selection.Copy
Windows("Pareto_Analyse_05_04.xls").Activate
' fügt die kopierten Teilergebnisse ein und setzt aktive Zelle einen Tag weiter
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(-1, 1).Select 'VOA
'Blattwechsel und NIO_Datei aktivieren
Call namesFS
ActiveWindow.Close False
Windows("Pareto_Analyse_05_04.xls").Activate
'Beschleuniger beenden
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.Save
MsgBox "Vor der nächsten Auswertung bitte Excel neu starten !"
'muss sein, da Excel sonst bei der nächsten Auswertung abstürzt
End Sub
Sub Aktivieren()
If ActiveSheet.Name = "Aufschreibung NA KOCKLER" Or ActiveSheet.Name = "Aufschreibung NA GÜTTLER" Or ActiveSheet.Name = "Aufschreibung WILLBERGER" Then
nm = ActiveSheet.Name
Z = ActiveCell.Row
S = ActiveCell.Column
Worksheets("Aufschreibung NA KOCKLER").Activate
Cells(Z, S).Select
Worksheets("Aufschreibung NA GÜTTLER").Activate
Cells(Z, S).Select
Worksheets("Aufschreibung WILLBERGER").Activate
Cells(Z, S).Select
Worksheets(nm).Activate
End If
End Sub
Sub namesFS()
Dim a As String
a = Right(ActiveSheet.Name, 4)
If a = "RGER" Then
Sheets("Aufschreibung NA KOCKLER").Activate
ElseIf a = "KLER" Then
Sheets("Aufschreibung NA GÜTTLER").Activate
ElseIf a = "TLER" Then
Sheets("Aufschreibung WILLBERGER").Activate
End If
Call aktivierenFS
End Sub
Gruß
Harald