|
Servus,
ich bin noch ganz der noob was VBA angeht, deshalb habe ich gehofft etwas Hilfe in diesem Forum zu bekommen.
Mein Makro sollte so aussehen. Ich habe eine sheet welches sagen wir mal Kennzahlen beinhaltet die auf untershiedliche Tochterunternehmen sortiert sind. Mit einem Makro möchte ich diese Sheets kopieren, ein Autofilter für eine Range einfügen und die FilterValues einfügen. So und das alles in einem Makro. Einzeln funktioniert alles wunderbar (also autofilter nach Lastrow und Sheets kopieren-umbenennen-autofilterkriterien-setzen), aber wenn ich versuche die zwei codes zusammen zu fügen, dann geht nichts mehr. Sehe nicht wo der Fehler ist. Habe schon alles ausprobiert.
Hier der code der nicht klappt:
[code]Sub CopySheets()
Dim LastRow As Long
Dim rng As Range
Dim SheetName As String
Application.ScreenUpdating = False
'Hier wird die letzte Zeile gesucht für die Range die dem Autofilter gegeben werden soll.
For Each wks In ThisWorkbook.Worksheets
Set rng = Sheets("Total (Monthly Development)").Cells
Set rng = Sheets("Total (Monthly Development)").Range("C1:C3000")
LastRow = Last(1, rng)
With rng
LastRow = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
'Hier wird der Autfilter gesetzt
Sheets("Total (Monthly Development)").AutoFilterMode = False
Sheets("Total (Monthly Development)").Range(Cells(3, 1), Cells(LastRow, 8)).Autofilter
'Hier werden die sheets kopiert und nach dem criterium benannt. Da es nur sechs sind, habe ich die einzelnen Vorgänge mehrmals eingetippt. Geht bestimmt auch einfacher.
SheetName = "1"
Sheets("Total (Monthly Development)").Copy After:=Sheets("Total (Monthly Development)")
ActiveSheet.Name = "1"
Sheets("1").Autofilter Field:=6, Criteria1:="1"
Sheets("1").Autofilter Field:=8, Criteria1:="Actual"
'Hier werden die Makro-Buttons entfernt.
Sheets("1").Shapes("Button 47").Select
Selection.Delete
Sheets("1").Shapes("Button 46").Select
Selection.Delete
'Habe davor mit activesheet gearbeitet, habe ohne versucht und funktionierte beides nicht. Nur als Erklärung weshalb die Commands sich unterscheiden.
SheetName = "2"
Sheets("Total (Monthly Development)").Copy After:=Sheets("Total (Monthly Development)")
ActiveSheet.Name = "2"
ActiveSheet.Shapes("Button 47").Select
Selection.Delete
ActiveSheet.Shapes("Button 46").Select
Selection.Delete
Selection.Autofilter Field:=6, Criteria1:="2"
Selection.Autofilter Field:=8, Criteria1:="Actual"
SheetName = "3"
Sheets("Total (Monthly Development)").Copy After:=Sheets("Total (Monthly Development)")
ActiveSheet.Name = "3"
ActiveSheet.Shapes("Button 47").Select
Selection.Delete
ActiveSheet.Shapes("Button 46").Select
Selection.Delete
Selection.Autofilter Field:=6, Criteria1:="3"
Selection.Autofilter Field:=8, Criteria1:="Actual"
SheetName = "4"
Sheets("Total (Monthly Development)").Copy After:=Sheets("Total (Monthly Development)")
ActiveSheet.Name = "4"
ActiveSheet.Shapes("Button 47").Select
Selection.Delete
ActiveSheet.Shapes("Button 46").Select
Selection.Delete
Selection.Autofilter Field:=6, Criteria1:="4"
Selection.Autofilter Field:=8, Criteria1:="Actual"
SheetName = "5"
Sheets("Total (Monthly Development)").Copy After:=Sheets("Total (Monthly Development)")
ActiveSheet.Name = "5"
ActiveSheet.Shapes("Button 47").Select
Selection.Delete
ActiveSheet.Shapes("Button 46").Select
Selection.Delete
Selection.Autofilter Field:=6, Criteria1:="5"
Selection.Autofilter Field:=8, Criteria1:="Actual"
SheetName = "6"
Sheets("Total (Monthly Development)").Copy After:=Sheets("Total (Monthly Development)")
ActiveSheet.Name = "6"
ActiveSheet.Shapes("Button 47").Select
Selection.Delete
ActiveSheet.Shapes("Button 46").Select
Selection.Delete
Selection.Autofilter Field:=6, Criteria1:="6"
Selection.Autofilter Field:=8, Criteria1:="Actual"
Next
Application.ScreenUpdating = True
End Sub[/code]
So, wie gesagt ich bin kein Profi, daher habe ich keinen Code, der Einfach bzw. kurz ist. Und im Moment funktioniert er auch nichtmal.
Ich würde mich über eure Hilfe freuen. Danke im Voraus.
P.S. Stellt euch vor die Zahlen 1-6 wären Branchen.
P.P.S Hier noch der code, für die Lastrow funktion:
[code]Function Last(choice As Long, rng As Range)
Dim lrw As Long
Dim lcol As Long
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function[/code]
|