Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1304to1308
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

Änderung eines Makros welches filtert

Änderung eines Makros welches filtert
22.03.2013 12:18:52
Jenny
Hallo alle zusammen, würde euch um eine Änderung an unten stehendem Makro bitten.
Es geht darum, dass das Makro nur Zeilen anzeigt, deren Wert in Spalte E größer 0 ist, also quasi das Ergebnis des unten stehenden Makros nochmal gefiltert wird nach E größer 0.
Seid ihr bitte so nett und helft mir?
Jenny
Public Sub Jenny_Filtert()
Dim objRange As Range, objCell As Range, objArea As Range
Dim avntValue() As Variant
Dim ialngIndex As Long
Dim objDictionary As Object
If ActiveSheet.AutoFilterMode Then
If TypeOf Selection Is Range Then
Set objRange = Intersect(Selection, Columns(3))
If Not objRange Is Nothing Then
For Each objArea In objRange.Areas
For Each objCell In objArea
ReDim Preserve avntValue(ialngIndex)
avntValue(ialngIndex) = objCell.Value
ialngIndex = ialngIndex + 1
Next
Next
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.AutoFilter.Range.Rows(1).AutoFilter Field:=3, _
Criteria1:=avntValue, Operator:=xlFilterValues
Set objRange = Nothing
Set objRange = Autofilter_List(, True, False, True)
If Not objRange Is Nothing Then
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each objArea In objRange.Areas
For Each objCell In objArea.Columns(1).Cells
If Not objDictionary.Exists(objCell.Text) Then
Call objDictionary.Add(objCell.Text, vbNullString)
objCell.Offset(0, 1).Value = 1
Else
objCell.Offset(0, 1).Value = 0
End If
Next
Next
ActiveSheet.AutoFilter.Range.Rows(1).AutoFilter Field:=2, _
Criteria1:=1
Cells(1, 3).Select
Set objRange = Nothing
Set objDictionary = Nothing
End If
Else
MsgBox "Bitte Zellen in Spalte C auswählen.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Bitte Zellen in Spalte C auswählen.", vbExclamation, "Hinweis"
End If
Else
MsgBox "Es ist kein Filter in der Tabelle.", vbExclamation, "Hinweis"
End If
End Sub

Private Function Autofilter_List( _
Optional ByRef probjSheet As Object = Nothing, _
Optional ByVal pvblnWithoutHeader As Boolean = True, _
Optional ByVal pvblnWholeRow As Boolean = True, _
Optional ByVal pvblnMessage As Boolean = False) As Range
If probjSheet Is Nothing Then Set probjSheet = ActiveSheet
If TypeOf probjSheet Is Worksheet Then
If probjSheet.AutoFilterMode Then
If probjSheet.FilterMode Then
With ActiveSheet.AutoFilter.Range.Offset(IIf(pvblnWithoutHeader, 1, 0))
With .Resize(.Rows.Count - IIf(pvblnWithoutHeader, 1, 0)).SpecialCells(xlCellTypeVisible)
If .Rows.Count > 1 Or .Areas.Count > 1 Then
Set Autofilter_List = .Cells
If pvblnWholeRow Then _
Set Autofilter_List = Autofilter_List.EntireRow
Else
If pvblnMessage Then _
MsgBox "Der Autofilter hat nichts gefunden.", vbExclamation, "Hinweis"
End If
End With
End With
Else
If pvblnMessage Then _
MsgBox "Kein Autofilter gesetzt.", vbExclamation, "Hinweis"
End If
Else
If pvblnMessage Then _
MsgBox "Kein Autofilter aktiv.", vbExclamation, "Hinweis"
End If
Else
If pvblnMessage Then _
MsgBox "Das Blatt ''" & probjSheet.Name & "'' ist keine Tabelle.", vbExclamation, "Hinweis"
End If
End Function

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Änderung eines Makros welches filtert
23.03.2013 11:12:45
Luschi
Hallo Jenny,
Dein Filtermakro ist viel zu kompliziert aufgebaut und es wird Einiges doppelt gemoppelt
ich habe das mal entsschlackt und die Unterfunktion 'Autofilter_List' total rausgeschmissen.
Deine Original-Makros habe ich auskommentiert, laufen aber bei Aktivierung wieder.
Habe mit ein paar Kommentaren versucht, Dir das Lesen meines Vba-Codes zu erleichtern.
https://www.herber.de/bbs/user/84514.xlsm
Gruß von Luschi
aus klein-Paris
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige