AW: Spezialfilter mit Variablen funktioniert nicht
18.09.2007 15:08:00
Andreas
Achso, hier ncoh der komplette Coden,
auch wenn er recht lang ist, aber ihr Cracks könnt das ja lesen wie ich ein Buch...
ab 'Spezialfilter hängt es mit der Fehlermeldung Laufzeitfehler 1004 Anwendungs- oder Objektorientierter Fehler
Sub KW_auswerten()
' KW_auswerten Makro
' Makro am 17.09.2007 von Andreas Werner erstellt
' Tastenkombination: Strg+a
With Range("B5:BA5").Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
If MsgBox("Ist die Zelle mit der KW die aktualisiert werden soll ausgewählt?", vbYesNo) = _
vbNo Then GoTo ende
Range("B5:BA5").Interior.ColorIndex = xlNone
'Einlesen der Suchdaten
kw_such = ActiveCell.Value
name_such = Cells(3, 18).Value
jahr_such = Cells(3, 4).Value
team_such = Cells(3, 12).Value
'Relevante Dateien öffnen
Dim Pfad, File As String
Pfad_gef = "L:\Auswertungen\Gefährdete Endtermine FT" & team_such & "\" & jahr_such & "\"
File_gef = "gef" & team_such & "" & kw_such & ".xls"
Pfad = "L:\Auswertungen\Produktivität FT" & team_such & "\" & jahr_such & "\ _
Einzelproduktivität\" & name_such & "\"
File = "" & name_such & "" & kw_such & ".xls"
Workbooks.Open Filename:=Pfad_gef + File_gef
Workbooks.Open Filename:=Pfad + File
'Persönlliche Rückmeldezeit der KW nach erster Spalte sortieren und Variablen übergeben
With Workbooks(File).Sheets(name_such & kw_such)
.Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Cells.Find(What:="Rückmeldetezeit (M) gesamt:", After:=ActiveCell, LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
rückmeld_m_ges = ActiveCell.Offset(0, 5)
Cells.Find(What:="Rückmeldetezeit (P) gesamt:", After:=ActiveCell, LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
rückmeld_p_ges = ActiveCell.Offset(0, 5)
Cells.Find(What:="Anwesenheitszeit gesamt:", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
anwesenheit_ges = ActiveCell.Offset(0, 5)
End With
'Letzte Zeile der Fertigungsauftträge festlegen
Range("B1:B500").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:= _
xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
letzte_zeile = ActiveCell.Row
'Spalten tauschen
Columns("H:H").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("Q:Q").Select
Selection.Cut
Columns("D:D").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("B1").Value = ("Auftrags-Nr")
Range("C1").Value = ("Bez")
Range("D1").Value = ("Vorgangsbeschreibung")
Range("E1").Value = ("Rest Au")
'Berechnung Rest Au
For i = 2 To letzte_zeile
Cells(i, 5).FormulaR1C1 = "=IF(RC[7]0,RC[7],RC[8]+RC[9])"
Next i
Range(Cells(2, 5), Cells(letzte_zeile, 5)).NumberFormat = "0.00"
'Zusatzblatt einfügen
Sheets.Add
With Sheets("Tabelle1")
.Select
.Move After:=Sheets(2)
.Name = "Gefiltert"
End With
'Filtern der Rückgemeldeten Zeiten nach "Auftragsnummer in der gefährdeten Liste vorhanden"
'Korrektur für einsatz Spezialfilter
Workbooks(File_gef).Sheets("gef" & team_such & kw_such & "Mo").Activate
Range("A1").FormulaR1C1 = "Auftrags-Nr"
Range("A2").Select
ActiveCell.FormulaR1C1 = "1"
'Spezialfilter
Workbooks(File).Sheets(name_such & kw_such).Activate
Workbooks(File).Sheets(name_such & kw_such).Range(Cells(1, 2), Cells(letzte_zeile, 5)). _
AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Workbooks(File_gef).Sheets("gef" & team_such & kw_such & "Mo").Range( _
"A1", Range("A65536").End(xlUp)) _
, CopyToRange:=Workbooks(File).Sheets("Gefiltert").Range("A1:D1"), Unique:=False
Range("D22").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("D21").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Range("A1").Select
ende:
End Sub