Filter aanpassen dmv macro

Status
Niet open voor verdere reacties.
J

Joete

Gebruiker
Lid geworden
19 sep 2008
Berichten
87
Vanuit een ander programma maken wij excellijsten, in die lijsten maken wij gebruik van filters.
Nu kan een gebruiker van deze lijsten de filters gebruiken om beperkingen in te stellen en dan via een knop gegevens kopiëren naar het klembord. Dit werkt allemaal goed, alleen staan er onder de lijst een heleboel lege regels (tabelstijl).

Nu wordt in het bestand kolom A gekopieerd naar het klembord, dus bij deze kolom wil ik dat bij het gebruik van de knop de lege regels uitgeschakeld worden. Op dit moment doe ik dat als volgt:
Code: 
ActiveSheet.ListObjects(Tabel).Range.AutoFilter field:=1, Criteria1:="<>"
Voor deze code gebruik ik een code om de naam van het filtergebied/tabel op te halen, vandaar de variabele "Tabel".

Dit werk goed, zolang men geen filter in kolom A (field:=1) gebruikt, gebruikt men wel een filter, dan wordt die gewist door deze code en worden de lege cellen verborgen.

Ik ben nu op zoek naar een code die bekijkt en onthoud of en welke filter in field:=1 gebruikt wordt, hier indien nodig aan toevoegt dat de lege cellen uitgeschakeld zijn, dan zijn dingetje doet (kolom A kopiëren) en vervolgens de filter weer terug zet zoals de gebruiker hem had ingesteld.

Loop hier al 2 dagen mee te stoeien, maar krijg het niet werkend. Wel codes gevonden die de huidige filters (maar dan ook meteen van alle kolommen) zouden moeten kunnen opslaan, verwijderen en weer toepassen, maar geen code die een filter kan aanpassen.

Waar ik naar mijn idee naar toe moet is dat de criteria uit field 1 in een array gestopt worden, deze array moet gecontroleerd worden of lege cellen hierin nog actief staan, zo ja, dan moeten die inactief, zo nee, dan is de filter verder OK. Maar die array van field 1 krijgen lukt mij niet... Iemand hier een heldere ingeving voor? Of misschien een andere manier hoe het zou kunnen?
 
Beste Joete,

Ik weet ook niet hoe je de actieve filters kunt wegschrijven/onthouden en er dan 1 toevoegt...
Ik heb wel een alternatief voor je, misschien dat dit ook voor jou werkt.

Onderstaande macro kopieert jouw tabel, maar alleen de zichtbare cellen.
Deze wordt dan op een nieuw blad geplaatst. Daarna wordt op deze nieuwe tabel jouw extra cirteria toegevoegd.
Volgens mij is krijg je dan in deze nieuwe tabel het gewenste resultaat.

Deze gegevens kun je dan kopiëren en het nieuwe worksheet gewoon weer weggooien.
Dan staan in de originele tabel de filters nog zoals je die hebt ingesteld.

ik heb mijn best gedaan om elke regel uit te leggen. Maar ik denk dat je hem wel zult snappen:thumb:
Code: 
Sub NGG_Filters()

Dim WSactief As Worksheet 'De sheet met jouw tabel
Dim WSnieuw As Worksheet 'De sheet waarop de nieuwe tabel komt te staan
Dim RNGtabel As Range 'De range van jouw tabel
Dim RNGnieuw As Range 'De range van de nieuwe tabel
Dim TBLbestaand As ListObject 'Jouw tabel
Dim TBLnieuw As ListObject 'De nieuwe tabel

'actieve sheet aanwijzen
Set WSactief = ActiveSheet
'tabel aanwijzen
Set TBLbestaand = WSactief.ListObjects(1) '"1" mag worden vervangen door de naam van jouw tabel
    TBLbestaand.ShowAutoFilter = True 'voor de zekerheid
    
'aanmaken van de nieuwe sheet (waarop de tabel komt te staan)
Set WSnieuw = Sheets.Add

'Range van originele tabel bepalen
Set RNGtabel = TBLbestaand.AutoFilter.Range
    'Kopieer de tabel (zonder koppen)
    RNGtabel.Offset(1, 0).Resize(RNGtabel.Rows.Count) _
        .SpecialCells(xlCellTypeVisible).Copy
    'Plak de tabel op het nieuwe sheet
    WSnieuw.Range("A1").PasteSpecial

'maak gebruik van de autoselect van excel om
'de range van de geplakte tabel te bepalen
Set RNGnieuw = Selection

'leg de geplakte tabel vast als ListObject (tabel)
Set TBLnieuw = WSnieuw.ListObjects.Add(xlSrcRange, RNGnieuw, , xlNo)
    
'filter toevoegen
TBLnieuw.Range.AutoFilter field:=1, Criteria1:="<>"
End Sub
 
Bedankt voor je reactie, maar ik heb helaas een hekel aan onnodig selecteren/kopiëren van gegevens...

Heb het probleem nu omzeild door lege cellen in mijn bereik te negeren, eigenlijk een hele simpele manier, probleem is alleen wel dat ie soms 1100 extra regels langs moet waar ie niks mee mag doen, maar dus wel moet controleren...

Een deel van de code die ik nu gebruik:
Code: 
    ' BatId's verzamelen
    Dim code As String
    Dim codeA As Integer
    code = ""
    codeA = 0
    With ActiveSheet.ListObjects(Tabel)
        For j = 1 To .ListRows.Count
            If .DataBodyRange.Rows(j).Hidden = False And Not IsEmpty(.DataBodyRange.Cells(j, 1).Value) Then
                code = code & .DataBodyRange.Cells(j, 1).Value & ";"
                codeA = codeA + 1
            End If
        Next j
    End With

Mocht iemand nog een betere oplossing weten dan hoor ik dat graag!
 
Laatst bewerkt:
Ik dacht even de specialcells(2) van de eerste kolom te kopiëren, of advancedfilter,.... misschien zie ik iets over het hoofd, maar zo heb je een leuke workaround.

Onderstaande code zet alle filters terug zoals ze stonden voor het kopiëren naar het klembord.
In het blauw staat de code voor het kopiëren naar het klembord.

N.b. Code in bladmodule van toepassing zetten, anders 'Activesheet.' voor 'Listobjects(1)' plaatsen in de code.
Code: 
Sub hsv()
Dim ftr As Filter, j As Long, x As Long
Application.ScreenUpdating = False
With ListObjects(1)
ReDim arr(0)
ReDim arr2(0)
  For Each ftr In .AutoFilter.Filters
    If ftr.On Then
       With ftr
            If IsArray(.Criteria1) Then
              arr(UBound(arr)) = Replace(Join(.Criteria1, ", "), "=", "")
             Else
              arr(UBound(arr)) = Replace(.Criteria1, "=", "")
            End If
            
            If .Operator <> 0 And .Operator < 3 Then
                arr2(UBound(arr2)) = .Criteria2
                x = .Operator
            End If
        End With
  End If
  ReDim Preserve arr(UBound(arr) + 1)
  ReDim Preserve arr2(UBound(arr2) + 1)
Next ftr
    .ShowAutoFilter = True
    .AutoFilter.ShowAllData
[COLOR=#0000ff]'============================== jouw code om kolom A naar het klembord te brengen[/COLOR]
[COLOR=#0000ff] With .Range[/COLOR]
[COLOR=#0000ff]   .AutoFilter 1, "<>"[/COLOR]
[COLOR=#0000ff]   .Copy[/COLOR]
[COLOR=#0000ff] End With[/COLOR]
[COLOR=#0000ff]'==============================[/COLOR]
  .Range.AutoFilter 1
  For j = 0 To UBound(arr) - 1
   If arr(j) <> "" Or arr2(j) <> "" Then
    If InStr(arr(j), ",") Then
       .Range.AutoFilter j + 1, Split(arr(j), ","), 7
     ElseIf arr2(j) <> "" Then
       .Range.AutoFilter j + 1, arr(j), x, arr2(j)
    Else
      .Range.AutoFilter j + 1, arr(j)
    End If
   End If
  Next
 End With
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan