Clever-Excel-Forum › Office-Anwendungen › Excel v
Tabellen Auszüge nach Bedingungen kopieren

Thema geschlossen 
Baumstrukturmodus
Tabellen Auszüge nach Bedingungen kopieren
steve1da Online
Benutzer
Registriert seit: 16.04.2014
Version(en): xl2016/365
#21
24.05.2015, 23:42
Hola,

Doppelarbeit wurde wahrscheinlich schon gemacht....dennoch:

http://www.office-loesung.de/p/viewtopic.php?f=166&t=692714

Gruß,
steve1da
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#22
25.05.2015, 08:55
Hallo Zusammen.

ich habe es mal mit dem Spezialfilter (wie auch hier empfohlen) umgesetzt.
Da funktioniert es (hoffentlich) in allen Versionen.


Code:
Option Explicit

'Kuwer

Sub TestSpezialfilter()
  Static Counter As Long
  Application.ScreenUpdating = False
  Call FilterAus
  Select Case Counter
    Case 1
      Call FehlerSpezialfilter
    Case 2
      Call EmailSpezialfilter
    Case 3
      Call FaxSpezialfilter
  End Select
  If Counter > 2 Then
    Counter = 0
  Else
    Counter = Counter + 1
  End If
  Application.ScreenUpdating = False
End Sub

Sub FehlerSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = "="
    .Range("D2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Fehler").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Fehler").Range("A1")
  End With
 
End Sub

Sub EmailSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = ">0"
    .Range("D2").Formula = "=true"
    .Range("F2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Email").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Email").Range("A1")
  End With

End Sub

Sub FaxSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = ">0"
    .Range("D2").Formula = "=true"
    .Range("E2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Fax").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Fax").Range("A1")
  End With

End Sub

Sub FilterAus()
  With Worksheets("Tabelle1")
    If .FilterMode Then
      If .AutoFilterMode Then
        .AutoFilterMode = False
      Else
        .ShowAllData
      End If
    End If
  End With
End Sub

Gruß Uwe


Angehängte Dateien
.xls   BeideFiltervarianten.xls (Größe: 67,5 KB / Downloads: 7)
Suchen
Top
WillWissen Offline
CEF-Moderator
Registriert seit: 10.04.2014
Version(en): Microsoft 365, mtl. Kanal
#23
25.05.2015, 10:00
@ Uwe

Hi Uwe,

kommen noch mehr Foren? ;)

Du hattest ja geschrieben, dass sich wohl ab XL2010 etwas geändert haben muss. Weißt du zwischenzeitlich, was geändert wurde? Liegt das eher an der Filterfunktion, die mit den unterschiedlichen Makros angestoßen werden oder eher an den Makros, die von den unterschiedlichen XL-Versionen nicht umgesetezt werden können?
Gruß Günter
Jeder Fehler erscheint unglaublich dumm, wenn andere ihn begehen.
angebl. von Georg Christoph Lichtenberg (1742-1799)
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#24
25.05.2015, 10:49
Hi Günter,

Zitat:kommen noch mehr Foren?
ich hab nicht weiter gesucht. :)

Es sieht so aus, dass die Steuerung des Autofilters per VBA ab 2010 endlich so funktioniert wie erwartet.

Gruß Uwe
Suchen
Top
FaDos Offline
pausiert
ThreadStarter
Registriert seit: 24.05.2015
Version(en): 2010
#25
25.05.2015, 11:01
(25.05.2015, 08:55)Kuwer schrieb: Hallo Zusammen.

ich habe es mal mit dem Spezialfilter (wie auch hier empfohlen) umgesetzt.
Da funktioniert es (hoffentlich) in allen Versionen.



Code:
Option Explicit

'Kuwer

Sub TestSpezialfilter()
  Static Counter As Long
  Application.ScreenUpdating = False
  Call FilterAus
  Select Case Counter
    Case 1
      Call FehlerSpezialfilter
    Case 2
      Call EmailSpezialfilter
    Case 3
      Call FaxSpezialfilter
  End Select
  If Counter > 2 Then
    Counter = 0
  Else
    Counter = Counter + 1
  End If
  Application.ScreenUpdating = False
End Sub

Sub FehlerSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = "="
    .Range("D2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Fehler").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Fehler").Range("A1")
  End With
 
End Sub

Sub EmailSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = ">0"
    .Range("D2").Formula = "=true"
    .Range("F2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Email").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Email").Range("A1")
  End With

End Sub

Sub FaxSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = ">0"
    .Range("D2").Formula = "=true"
    .Range("E2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Fax").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Fax").Range("A1")
  End With

End Sub

Sub FilterAus()
  With Worksheets("Tabelle1")
    If .FilterMode Then
      If .AutoFilterMode Then
        .AutoFilterMode = False
      Else
        .ShowAllData
      End If
    End If
  End With
End Sub

Gruß Uwe

Danke 

Ich benutze dein Spezialfilter
Suchen
Top
FaDos Offline
pausiert
ThreadStarter
Registriert seit: 24.05.2015
Version(en): 2010
#26
26.05.2015, 01:36
(25.05.2015, 11:01)FaDos schrieb:
(25.05.2015, 08:55)Kuwer schrieb: Hallo Zusammen.

ich habe es mal mit dem Spezialfilter (wie auch hier empfohlen) umgesetzt.
Da funktioniert es (hoffentlich) in allen Versionen.




Code:
Option Explicit

'Kuwer

Sub TestSpezialfilter()
  Static Counter As Long
  Application.ScreenUpdating = False
  Call FilterAus
  Select Case Counter
    Case 1
      Call FehlerSpezialfilter
    Case 2
      Call EmailSpezialfilter
    Case 3
      Call FaxSpezialfilter
  End Select
  If Counter > 2 Then
    Counter = 0
  Else
    Counter = Counter + 1
  End If
  Application.ScreenUpdating = False
End Sub

Sub FehlerSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = "="
    .Range("D2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Fehler").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Fehler").Range("A1")
  End With
 
End Sub

Sub EmailSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = ">0"
    .Range("D2").Formula = "=true"
    .Range("F2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Email").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Email").Range("A1")
  End With

End Sub

Sub FaxSpezialfilter()
  With Worksheets("Filter")
    
    'CriteriaRange wird neu erstellt
    .Range("A1:F2") = ""
    Worksheets("Tabelle1").Range("A1:F1").Copy .Range("A1")
    .Range("A2").Formula = "<>Call"
    .Range("C2").Formula = ">0"
    .Range("D2").Formula = "=true"
    .Range("E2").Formula = "=true"
    
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterInPlace, _
      CriteriaRange:=.Range("A1:F2")
      
    Worksheets("Fax").Range("A1").CurrentRegion = ""
    Worksheets("Tabelle1").Range("A1").CurrentRegion.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=.Range("A1:F2"), _
      CopyToRange:=Worksheets("Fax").Range("A1")
  End With

End Sub

Sub FilterAus()
  With Worksheets("Tabelle1")
    If .FilterMode Then
      If .AutoFilterMode Then
        .AutoFilterMode = False
      Else
        .ShowAllData
      End If
    End If
  End With
End Sub

Gruß Uwe

Danke 

Ich benutze dein Spezialfilter

Ist es auch möglich die Spalten die ich nicht brauche gleichzeitig auszublenden?
Es wären Spalten : H, K, L, O, R, S, T, U, W

Danke
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#27
26.05.2015, 07:50
Hallo,

das Ausblenden könntest Du ja auch einmal händisch machen und gut ist. ;)
Als Code dann so:
Code:
Sub SpaltenAusblenden()
 Worksheets("Tabelle1").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
 Worksheets("Fehler").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
 Worksheets("Email").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
 Worksheets("Fax").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
End Sub

Gruß Uwe
Suchen
Top
FaDos Offline
pausiert
ThreadStarter
Registriert seit: 24.05.2015
Version(en): 2010
#28
27.05.2015, 23:12
(26.05.2015, 07:50)Kuwer schrieb: Hallo,

das Ausblenden könntest Du ja auch einmal händisch machen und gut ist. ;)
Als Code dann so:

Code:
Sub SpaltenAusblenden()
 Worksheets("Tabelle1").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
 Worksheets("Fehler").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
 Worksheets("Email").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
 Worksheets("Fax").Range("H1,K1,L1,O1,R1,S1,T1,U1,W1").EntireColumn.Hidden = True
End Sub

Gruß Uwe

Super Danke
Suchen
Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 2 Gast/Gäste