Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1044to1048
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Filtern kopieren Auswahlkriterium aus Liste

Filtern kopieren Auswahlkriterium aus Liste
04.02.2009 08:16:00
Silvi
Guten Morgen!
Hab da wiedermal ein Problem und will mal versuchen es kurz und knapp zu beschreiben. In einer Datei filtere ich zunächst per VBA die Kostenstellen heraus und stelle sie in ein anderes Tabellenblatt (Kostenstellen), in diesem Blatt werden erstmal alle doppelten Kostenstellen gelöscht (dauert ziemlich lange, vielleicht weiß da auch jemand was besseres?). Dann werden neue Tabellenblätter angelegt, die nach den Kostenstellen in der Liste benannt werden.
Jetzt sollen die Daten in der Tabelle "je Kto-KST" gefiltert werden nach den Kriterien, also Kostenstellen, die in der Tabelle "Kostenstellen" stehen und dann in die entsprechenden nach Kostenstellen benannten Tabellenblätter kopiert werden. Hoffe das ist einigermaßen verständlich ausgedrückt. Vielleicht hat ja jemand eine Idee wie man das elegant lösen kann?
Hier noch eine Beispieldatei mit den Makros die ich bis jetzt zusammengebastelt habe...
https://www.herber.de/bbs/user/59063.xls
Vielen Dank schon mal!
LG
Silvi

19
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Filtern kopieren Auswahlkriterium aus Liste
04.02.2009 08:50:41
Josef
Hallo Silvi,
probier mal dieses Makro.
Das Auflisten der Kostenstellen in "Kostenstellen" ist nicht nötig.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filternNachKst()
    Dim objWsData As Worksheet, objWsKst As Worksheet
    Dim lngR As Long, lngHeader As Long, lngNext As Long
    
    On Error GoTo ErrExit
    GMS
    
    Set objWsData = Sheets("je Kto-KST")
    
    lngHeader = 2 'Zeile mit den Überschriften
    
    With objWsData
        If .AutoFilterMode Then .Range("A2").AutoFilter
        
        .Range("A2").CurrentRegion.Sort Key1:=.Range("G3"), _
            Order1:=xlAscending, _
            Header:=xlGuess
        For lngR = lngHeader + 1 To .Cells(Rows.Count, 7).End(xlUp).Row
            If .Cells(lngR, 7) <> "" Then
                If SheetExist(CStr(.Cells(lngR, 7))) Then
                    Set objWsKst = Sheets(CStr(.Cells(lngR, 7)))
                Else
                    Set objWsKst = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
                    Sheets(Sheets.Count).Name = CStr(.Cells(lngR, 7))
                    objWsKst.Rows(lngHeader) = objWsData.Rows(lngHeader).Value
                End If
                
                lngNext = Application.Max(lngHeader + 1, objWsKst.Cells(Rows.Count, 7).End(xlUp).Row + 1)
                objWsKst.Rows(lngNext) = objWsData.Rows(lngR).Value
            End If
        Next
    End With
    
    objWsData.Activate
    
    ErrExit:
    If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWsData = Nothing
    Set objWsKst = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long
    
    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With
    
End Sub

Gruß Sepp

Anzeige
AW: Filtern kopieren Auswahlkriterium aus Liste
04.02.2009 08:58:27
Silvi
Wow!
Bin begeistert, funktioniert einwandfrei.
Was würde ich ohne Euch hier machen?!
VIELEN DANK SEPP!
AW: Filtern kopieren Auswahlkriterium aus Liste
04.02.2009 08:52:00
Mike
Hallo Silvi,
mit solchen Auswertungen hatte ich auch lange zu kämpfen, habe
dies nun jedoch mit Vorlagen gelöst.
-> monatlich der Datenbestand neu
-> pro KST ein Blatt fix, das mit SVerweis() zum Datenbestand gelinkt ist
Gibts 'ne neue KST muss einfach ein neues Datenblatt kopiert
werden.
Gruss
Mike
doch noch ne Frage an Sepp
04.02.2009 09:26:40
Silvi
Hallo Sepp,
in meiner Testdatei funktioniert das Makro super gut, in meiner echten Datei habe ich aber ein kleines Problem, da sind plötzlich die Überschriften weg. Dachte es liegt vielleicht daran, dass ich in der ersten Zeile Formeln habe (Teilergebnis), aber auch wenn ich alles in Werte kopiere sind plötzlich die Überschriften weg.
Leider bin ich kein Profi in VBA und verstehe noch nicht mal die Hälfte von dem was Du da geschrieben hast. Vielleicht kannst Du mir da nochmal weiterhelfen?
Gruß
Silvi
Anzeige
AW: doch noch ne Frage an Sepp
04.02.2009 09:28:58
Josef
Hallo Silvi,
da meine Glaskugel zum Jahresservice ist, müsste ich schon von dir erfahren, wie deine "echte" Tabelle aussieht.
Gruß Sepp

AW: doch noch ne Frage an Sepp
04.02.2009 10:08:00
Silvi
Hi Sepp,
die Tabellen ("je Kto-KST") sehen absolut gleich aus, in der echten Datei sind nur noch Formeln enthalten. Das Makro läuft auch in der echten Datei eigentlich fehlerfrei nur das Tabellenblatt "je Kto-KST" werden die Überschriften in der 2. Zeile und die 1. Zeile mit der Fromel Teilergebnis gelöscht. Es sieht so aus als wenn die ganze Tabelle um 2 Zeilen nach oben verschoben wird und damit die ersten beiden Zeilen überschrieben werden.
Silvi
Anzeige
AW: doch noch ne Frage an Sepp
04.02.2009 10:17:08
Josef
Hallo Silvi,
dann so.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filternNachKst()
    Dim objWsData As Worksheet, objWsKst As Worksheet
    Dim lngR As Long, lngHeader As Long, lngNext As Long
    
    On Error GoTo ErrExit
    GMS
    
    Set objWsData = Sheets("je Kto-KST")
    
    lngHeader = 2 'Zeile mit den Überschriften
    
    With objWsData
        If .AutoFilterMode Then .Range("A2").AutoFilter
        
        .Range("A2:T" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort Key1:=.Range("G3"), _
            Order1:=xlAscending, _
            Header:=xlGuess
        For lngR = lngHeader + 1 To .Cells(Rows.Count, 7).End(xlUp).Row
            If .Cells(lngR, 7) <> "" Then
                If SheetExist(CStr(.Cells(lngR, 7))) Then
                    Set objWsKst = Sheets(CStr(.Cells(lngR, 7)))
                Else
                    Set objWsKst = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
                    Sheets(Sheets.Count).Name = CStr(.Cells(lngR, 7))
                    objWsKst.Rows(lngHeader) = objWsData.Rows(lngHeader).Value
                End If
                
                lngNext = Application.Max(lngHeader + 1, objWsKst.Cells(Rows.Count, 7).End(xlUp).Row + 1)
                objWsKst.Rows(lngNext) = objWsData.Rows(lngR).Value
            End If
        Next
    End With
    
    objWsData.Activate
    
    ErrExit:
    If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWsData = Nothing
    Set objWsKst = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long
    
    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With
    
End Sub

Gruß Sepp

Anzeige
AW: doch noch ne Frage an Sepp
04.02.2009 10:44:00
Silvi
Sepp Du bist mein Held!
Also, es klappt jetzt besser, was ich nur nicht verstehe ist, warum das Makro die Formeln in der Tabelle "je Kto-KST" so durcheinander schmeißt und die erste Zeile mit dem Teilergebnis nicht mit in die Tabellenblätter kopiert. Ich will Dich aber nicht länger nerven, vielleicht komm ich ja auch mal irgendwann selber dahinter.
Auf jeden Fall hilft mir das schon sehr viel weiter.
LG
Silvi
AW: doch noch ne Frage an Sepp
04.02.2009 11:26:01
Josef
Hallo Silvi,
also du nervst überhaupt nicht, das Forum ist ja dazu da, anderen zu Helfen.
Von den Zeilen oberhalb der Tabelle hast du ja auch nie gesprochen, woher sollte das Makro oder ich das also wissen? ;-))
Um das Makro zu beschleunigen, habe ich die Tabelle vorher sortiert, das muss aber nicht sein.
Teste mal diesen Code
Gruß Sepp

Anzeige
Oups, Code vergessen ;-)
04.02.2009 11:26:00
Josef
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filternNachKst()
    Dim objWsData As Worksheet, objWsKst As Worksheet
    Dim lngR As Long, lngHeader As Long, lngNext As Long
    
    On Error GoTo ErrExit
    GMS
    
    Set objWsData = Sheets("je Kto-KST")
    
    lngHeader = 2 'Zeile mit den Überschriften
    
    With objWsData
        If .AutoFilterMode Then .Range("A2").AutoFilter
        
        ' .Range("A2:T" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort Key1:=.Range("G3"), _
            ' Order1:=xlAscending, _
            ' Header:=xlGuess

        For lngR = lngHeader + 1 To .Cells(Rows.Count, 7).End(xlUp).Row
            If .Cells(lngR, 7) <> "" Then
                If SheetExist(CStr(.Cells(lngR, 7))) Then
                    Set objWsKst = Sheets(CStr(.Cells(lngR, 7)))
                Else
                    Set objWsKst = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
                    Sheets(Sheets.Count).Name = CStr(.Cells(lngR, 7))
                    objWsData.Range(objWsData.Cells(1, 1), objWsData.Cells(lngHeader, 20)).Copy objWsKst.Range("A1")
                End If
                
                lngNext = Application.Max(lngHeader + 1, objWsKst.Cells(Rows.Count, 7).End(xlUp).Row + 1)
                objWsKst.Rows(lngNext) = objWsData.Rows(lngR).Value
            End If
        Next
    End With
    
    objWsData.Activate
    
    ErrExit:
    If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWsData = Nothing
    Set objWsKst = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long
    
    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With
    
End Sub

Gruß Sepp

Anzeige
AW: Oups, Code vergessen ;-)
04.02.2009 11:39:00
Silvi
Hi Sepp,
genau so funktioniert es richtig, vielen Dank!
Wenn Du sagst, dass ich nicht nerve, dann habe ich doch direkt noch eine Frage ;o)
Wenn ich die einzelnen Tabellen jetzt noch schöner formatieren möchte, wo muß ich dann in das Makro eingreifen um die gewünschten Formate zu hinterlegen wie z.B. Schriftfarbe-/größe oder immer die ersten 4 Spalten ausblenden?
Danke nochmal!
Silvi
AW: Oups, Code vergessen ;-)
04.02.2009 12:04:07
Josef
Hallo Silvi,
ja genau, siehe Code.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filternNachKst()
    Dim objWsData As Worksheet, objWsKst As Worksheet
    Dim lngR As Long, lngHeader As Long, lngNext As Long
    
    On Error GoTo ErrExit
    GMS
    
    Set objWsData = Sheets("je Kto-KST")
    
    lngHeader = 2 'Zeile mit den Überschriften
    
    With objWsData
        If .AutoFilterMode Then .Range("A2").AutoFilter
        
        ' .Range("A2:T" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort Key1:=.Range("G3"), _
            ' Order1:=xlAscending, _
            ' Header:=xlGuess

        For lngR = lngHeader + 1 To .Cells(Rows.Count, 7).End(xlUp).Row
            If .Cells(lngR, 7) <> "" Then
                If SheetExist(CStr(.Cells(lngR, 7))) Then
                    Set objWsKst = Sheets(CStr(.Cells(lngR, 7)))
                Else
                    Set objWsKst = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
                    Sheets(Sheets.Count).Name = CStr(.Cells(lngR, 7))
                    objWsData.Range(objWsData.Cells(1, 1), objWsData.Cells(lngHeader, 20)).Copy objWsKst.Range("A1")
                End If
                
                lngNext = Application.Max(lngHeader + 1, objWsKst.Cells(Rows.Count, 7).End(xlUp).Row + 1)
                objWsKst.Rows(lngNext) = objWsData.Rows(lngR).Value
                'Formatierungen etc. nach diesem Schema.
                objWsKst.Columns("A:D").Hidden = True
                objWsKst.Columns("F").Font.Bold = True
                objWsKst.Columns("C").Font.ColorIndex = 3
            End If
            
        Next
    End With
    
    objWsData.Activate
    
    ErrExit:
    If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWsData = Nothing
    Set objWsKst = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long
    
    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With
    
End Sub

Gruß Sepp

Anzeige
nochmal ne Frage... an Sepp
06.02.2009 13:01:00
Silvi
Lieber Sepp,
Du hattest mir ja letztens so toll geholfen, hat auch alles super geklappt, jetzt musste ich aber noch ein paar Änderungen vornehmen und nun sieht die Abfrage etwas anders aus. Habe Deinen Code etwas umgeschrieben, aber krieg das doch nicht so richtig hin.
Habe eine andere Tabelle als Datentabelle genommen (Tabelle1 statt je Kto-KST) mit ein paar Spalten mehr und möchte jetzt noch ein zusätzliches Auswahlkriterium einbringen, dass dann in einer anderen Tabelle "Zeilenübersicht" Range("C1") steht.
Kannst Du mir nochmal helfen und mir sagen wie ich Deinen Code verändern muß?
https://www.herber.de/bbs/user/59174.xls
LG
Silvi
Anzeige
AW: nochmal ne Frage... an Sepp
06.02.2009 16:16:00
Josef
Hallo Silvi,
klar helfe ich dir nochmals, aber du musst mir schon erklären, was du genau willst.
Aus deinem Code werd' ich nicht schlau.
Gruß Sepp

AW: nochmal ne Frage... an Sepp
09.02.2009 07:07:00
Silvi
Moin Sepp,
Danke dass du dich noch gemeldet hast! Natürlich hast du recht, ich versuch es mal zu erklären.
Habe zwei Tabellen, in Tabelle1 stehen alle Daten die ich brauche, in Tabelle "Zeilenübersicht" werden ein paar Daten zusammengefaßt hat aber nix mit dem Makro zu tun, darin steht aber der Name den ich für die Abfrage brauche. In Tabelle1 soll nach dem Namen der in Blatt "Zeilenübersicht" in Zelle C1 steht gefiltert werden, in Spalte A stehen die Kostenstellen, in Spalte L nach allen nichtleeren Zellen filtern.
Mit dem Makro sollen die Kostenstellen nach den Verantwortlichen (Name) herausgefiltert werden und dann der Bereich von Spalte A bis Z in ein neues Tabellenblatt kopiert werden und das Tabellenblatt erhält dann automatisch den Namen der Kostenstelle die kopiert worden ist. In der ersten Zeile des Tabellenblattes sollte eine Summenzeile sein.
Ich hoffe, jetzt wird es deutlicher, die Datei hatte ich ja schon hochgeladen.
LG
Silvi
Anzeige
AW: nochmal ne Frage... an Sepp
10.02.2009 01:17:49
Josef
Hallo Slvi,
hatte jetzt erst Zeit.
Probier mal.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filternNachKst()
    Dim objWsData As Worksheet, objWsKst As Worksheet, objWs As Worksheet
    Dim lngR As Long, lngHeader As Long, lngNext As Long
    Dim arrSheets() As String, lngIndex As Long
    Dim rngFilter As Range
    
    On Error GoTo ErrExit
    GMS
    
    Redim arrSheets(0)
    
    Set objWsData = Sheets("Tabelle1")
    
    lngHeader = 1 'Zeile mit den Überschriften
    
    With objWsData
        lngR = Application.Max(3, .Cells(Rows.Count, 1).End(xlUp).Row)
        Set rngFilter = .Range("A2:Z" & lngR)
        
        For lngR = lngHeader + 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(lngR, 1) <> "" Then
                If SheetExist(CStr(.Cells(lngR, 1))) Then
                    Set objWsKst = Sheets(CStr(.Cells(lngR, 1)))
                Else
                    Set objWsKst = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
                    Sheets(Sheets.Count).Name = CStr(.Cells(lngR, 1))
                    objWsData.Range(objWsData.Cells(1, 1), objWsData.Cells(lngHeader, 26)).Copy objWsKst.Range("A1")
                End If
                
                If IsError(Application.Match(objWsKst.Name, arrSheets, 0)) Then
                    If arrSheets(0) <> "" Then Redim Preserve arrSheets(UBound(arrSheets) + 1)
                End If
                arrSheets(UBound(arrSheets)) = objWsKst.Name
                lngNext = Application.Max(lngHeader + 1, objWsKst.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                objWsKst.Rows(lngNext) = objWsData.Rows(lngR).Value
                
            End If
        Next
    End With
    
    'Formatierung der Tabbellen
    For lngIndex = 0 To UBound(arrSheets)
        With Sheets(arrSheets(lngIndex))
            .Columns("A:D").Hidden = True
            .Columns("T").Hidden = True
            .Columns("E").Font.Bold = True
            .Columns("C").Font.ColorIndex = 3
            .Columns("H:S").NumberFormat = "#,##0"
            .Columns("M").Style = "Percent"
            .Columns("S").Style = "Percent"
            .Columns("E:E").EntireColumn.AutoFit
            .Columns("G:G").EntireColumn.AutoFit
            With .PageSetup
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
                .CenterHeader = "Kostenstellenvergleich"
                .LeftFooter = arrSheets(lngIndex) & Format(Date, "dd.mm.yy")
            End With
        End With
    Next
    
    'Abfrage "Zeilenübersicht C1"
    
    Set objWsKst = Sheets("Zeilenübersicht")
    
    rngFilter.AutoFilter
    rngFilter.AutoFilter Field:=5, Criteria1:="=" & objWsKst.Range("C1").Text
    rngFilter.AutoFilter Field:=12, Criteria1:="<>"
    
    
    If SheetExist(objWsKst.Range("C1").Text) Then
        Set objWs = Sheets(objWsKst.Range("C1").Text)
        objWs.UsedRange.Clear
    Else
        Set objWs = ThisWorkbook.Worksheets.Add(after:=objWsKst)
        objWs.Name = objWsKst.Range("C1").Text
    End If
    
    With objWs
        rngFilter.SpecialCells(xlCellTypeVisible).Copy .Range("A2")
        rngFilter.AutoFilter
        lngR = Application.Max(3, .Cells(Rows.Count, 1).End(xlUp).Row)
        For lngIndex = 14 To 26
            .Cells(1, lngIndex).Formula = "=Sum(" & .Range(.Cells(3, lngIndex), .Cells(lngR, lngIndex)).Address & ")"
        Next
    End With
    
    objWsData.Activate
    
    ' ActiveWorkbook.SaveAs ("E:\Daten\Kostenstellenrechnung\Berichte\Kostenstellen\Quelle-Vergleich-Plan-Ist " & Range("C1") & ".xls")
    
    ErrExit:
    If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWsData = Nothing
    Set objWsKst = Nothing
    Set objWs = Nothing
    Set rngFilter = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long
    
    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With
    
End Sub

Gruß Sepp

AW: nochmal ne Frage... an Sepp
10.02.2009 07:01:00
Silvi
Hi Sepp,
vielen Dank für Deine Mühe und arbeit die Du bis jetzt investiert hast. Habe den Code eben getestet und verstehe grade überhaupt nicht was dabei rausgekommen ist. Hab mich wahrscheinlich wiedermal etwas blöd ausgedrückt. Sorry! Ich versuch es nochmal:
In dem Blatt Zeilenübersicht steht der Name nachdem zunächst in Tabelle1 gefiltert werden soll, dann soll das Makro wie vorher weiterlaufen, also von den gefilterten Daten die Kostenstellen des Verantwortlichen auf ein neues Tabellenblatt kopieren.
In der ersten Datei hatte ich in dem Blatt (je Kto-KST) schon alle Daten für den Kostenstellenverantwortlichen mit einer Formel aus Tabelle1 herausgefiltert und dein Code hat dann aus diesem Blatt die Kostenstellen herausgesucht und in neue Blätter kopiert.
Wollte mir das Blatt mit den Formeln sparen und direkt auf die Datentabelle zugreifen.
LG
Silvi
AW: nochmal ne Frage... an Sepp
10.02.2009 11:21:00
Josef
Hallo Silvi,
jetzt hab ich es verstanden, glaub' ich wenigstens;-))
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub filternNachKst()
    Dim objWsData As Worksheet, objWsKst As Worksheet, objWs As Worksheet
    Dim lngR As Long, lngHeader As Long, lngNext As Long
    Dim arrSheets() As String, lngIndex As Long
    Dim rngFilter As Range
    
    On Error GoTo ErrExit
    GMS
    
    Redim arrSheets(0)
    
    Set objWsData = Sheets("Tabelle1")
    
    lngHeader = 2 'Zeile mit den Überschriften
    
    With objWsData
        lngR = Application.Max(3, .Cells(Rows.Count, 1).End(xlUp).Row)
        Set rngFilter = .Range("A2:Z" & lngR)
        'Abfrage "Zeilenübersicht C1"
        
        
        rngFilter.AutoFilter
        rngFilter.AutoFilter Field:=5, Criteria1:="=" & Sheets("Zeilenübersicht").Range("C1").Text
        rngFilter.AutoFilter Field:=12, Criteria1:="<>"
        
        For lngR = lngHeader + 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Rows(lngR).Hidden = False Then
                If .Cells(lngR, 1) <> "" Then
                    If SheetExist(CStr(.Cells(lngR, 1))) Then
                        Set objWsKst = Sheets(CStr(.Cells(lngR, 1)))
                    Else
                        Set objWsKst = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
                        Sheets(Sheets.Count).Name = CStr(.Cells(lngR, 1))
                    End If
                    
                    If IsError(Application.Match(objWsKst.Name, arrSheets, 0)) Then
                        If arrSheets(0) <> "" Then Redim Preserve arrSheets(UBound(arrSheets) + 1)
                        arrSheets(UBound(arrSheets)) = objWsKst.Name
                        objWsKst.Cells.Clear
                        objWsKst.Columns.Hidden = False
                        objWsKst.Rows.Hidden = False
                    End If
                    
                    objWsData.Range(objWsData.Cells(1, 1), objWsData.Cells(lngHeader, 26)).Copy objWsKst.Range("A1")
                    
                    lngNext = Application.Max(lngHeader + 1, objWsKst.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    objWsKst.Rows(lngNext) = objWsData.Rows(lngR).Value
                    
                End If
            End If
        Next
        rngFilter.AutoFilter
    End With
    
    'Formatierung der Tabbellen
    For lngIndex = 0 To UBound(arrSheets)
        With Sheets(arrSheets(lngIndex))
            .Columns("A:D").Hidden = True
            .Columns("T").Hidden = True
            .Columns("E").Font.Bold = True
            .Columns("C").Font.ColorIndex = 3
            .Columns("H:S").NumberFormat = "#,##0"
            .Columns("M").Style = "Percent"
            .Columns("S").Style = "Percent"
            .Columns("E:E").EntireColumn.AutoFit
            .Columns("G:G").EntireColumn.AutoFit
            With .PageSetup
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
                .CenterHeader = "Kostenstellenvergleich"
                .LeftFooter = arrSheets(lngIndex) & Format(Date, "dd.mm.yy")
            End With
        End With
    Next
    
    objWsData.Activate
    
    ' ActiveWorkbook.SaveAs ("E:\Daten\Kostenstellenrechnung\Berichte\Kostenstellen\Quelle-Vergleich-Plan-Ist " & Range("C1") & ".xls")
    
    ErrExit:
    If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
    GMS True
    Set objWsData = Nothing
    Set objWsKst = Nothing
    Set objWs = Nothing
    Set rngFilter = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Public Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long
    
    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With
    
End Sub

Gruß Sepp

AW: nochmal ne Frage... an Sepp
10.02.2009 14:08:10
Silvi
Hallo Sepp,
bin grade erst dazu gekommen es zu testen, klappt alles wunderbar!
Danke vielmals!
Gruß
Silvi

320 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige