Für Leute mit Hang zum Masochismus
07.05.2004 12:50:12
Harald
untenstehend mein Code, der leider die Angewohnheit hat beim zweiten Durchlauf für ne zweite Auswertung, Excel dermaßen abzuschießen, dass ich den PC neu starten muss.
Wenn jemand die Muße hat diesen Monstercode durchzuschauen um den Fehler zu entdecken, wäre ich zugegebenermaßen angenehm überrascht.
Der Code hat den Zweck Quelldateien zu öffnen, eine Teilergebnisauswertung zu fahren und dann die gewonnen Daten in die Zieldatei zu kopieren.
Die Quelldatei wird übrigens auf einem Rechner ohne Excel generiert (Oracle) und als NIO_FS2004Datum.xls abgelegt.
Sub DateiOeffnenRS()
'Beschleuniger
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'setzt gleiche Zelle in den Schichtblättern
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
'öffnet Hinterachsdatei für Datum der aktiven Zelle
Dim Filename As String
Filename = "I:\NIO_Zahlen\RS\NIO_RS" & 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
For g = 2 To 8
If Cells(g, 3) > 2 Then Cells(g, 3).EntireRow.ClearContents
Next g
Rows("2:8").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
'Auswertung
Range("C10").Select
Selection.Copy
Range("C2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("C11").Select
Selection.Copy
Range("C4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("C12").Select
Application.CutCopyMode = False
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("C3").ClearContents
Range("C5").ClearContents
Range("C7").ClearContents
Range( _
"V:W,AD:AE,AF:AM,AR:AS,AV:AW,BA:BD,BQ:BR" _
).Delete Shift:=xlToLeft
Columns("BJ:BJ").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Range("AY2").FormulaR1C1 = "=VALUE(LEFT(RC[20],3))"
Range("AZ2").FormulaR1C1 = "=VALUE(RIGHT(RC[19],3))"
Range("BA2").FormulaR1C1 = "=VALUE(LEFT(RC[20],3))"
Range("BB2").FormulaR1C1 = "=VALUE(LEFT(RC[20],3))"
Range("BC2").FormulaR1C1 = "=VALUE(RIGHT(RC[19],3))"
Range("BD2").FormulaR1C1 = "=VALUE(LEFT(RC[19],3))"
Range("BE2").FormulaR1C1 = "=VALUE(RIGHT(RC[18],3))"
Range("BF2").FormulaR1C1 = "=VALUE(LEFT(RC[20],3))"
Range("BG2").FormulaR1C1 = "=VALUE(LEFT(RC[21],3))"
Range("BH2").FormulaR1C1 = "=VALUE(LEFT(RC[22],3))"
Range("BI2").FormulaR1C1 = "=VALUE(LEFT(RC[29],3))"
Range("BJ2").FormulaR1C1 = "=VALUE(LEFT(RC[29],3))"
Range("BK2").FormulaR1C1 = "=VALUE(LEFT(RC[31],3))"
Range("BL2").FormulaR1C1 = "=VALUE(RIGHT(RC[30],3))"
Range("BM2").FormulaR1C1 = "=VALUE(LEFT(RC[31],3))"
Range("BN2").FormulaR1C1 = "=VALUE(LEFT(RC[31],3))"
Range("BO2").FormulaR1C1 = "=VALUE(LEFT(RC[31],3))"
Range("AY2:BO2").Select
Selection.AutoFill Destination:=Range("AY2:BO7"), Type:=xlFillDefault
Range("AY2:BO7").Select
Range("A1").Select
Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, _
34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, _
60, 61, 62, 63, 64, 65, 66, 67), Replace:=False, PageBreaks:=False, _
SummaryBelowData:=True
Range("C4:BO4").Select
Selection.Copy
'wechseln
Windows("Pareto_Analyse_05_04.xls").Activate
' fügt die kopierten Teilergebnisse ein und setzt aktive Zelle einen Tag weiter
ActiveCell.Offset(44, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(-44, 1).Select 'HIA
'Blattwechsel und NIO_Datei aktivieren
Call namesRS
' Kopiert Teilergebnis von Schicht 2 Hinterachse
Range("C7:BR7").Select
Selection.Copy
'wechseln
Windows("Pareto_Analyse_05_04.xls").Activate
' fügt die kopierten Teilergebnisse ein und setzt aktive Zelle einen Tag weiter
ActiveCell.Offset(44, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(-44, 1).Select 'HIA
'Blattwechsel und NIO_Datei aktivieren
Call namesRS
' Kopiert Teilergebnis von Schicht 3 Hinterachse
Range("C10:BR10").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(44, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(-44, 1).Select 'HIA
'Blattwechsel und NIO_Datei aktivieren
Call namesRS
Application.CutCopyMode = False
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 !"
End Sub
Sub namesRS()
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 aktivierenRS
End Sub
Sub aktivierenRS()
Dim wnd As Window
For Each wnd In Windows
If wnd.Caption Like "NIO_RS2004*.xls" Then
wnd.Activate
Exit For
End If
Next wnd
End Sub
Wer es bis hierhin geschafft hat und ne Lösung weiß, hat sich ne Kiste Bier verdient. Abzuholen im Saarland.
Gruß
Harald