Autofilter op Tabel en copy naar nieuw tabblad

Status
Niet open voor verdere reacties.
SjofaaSj

SjofaaSj

Gebruiker
Lid geworden
24 feb 2014
Berichten
44
Met een autofilter wil ik een tabel filteren op een kolom (USER) voor elke verschillende waarde in die kolom (die niet leeg is of gelijk aan nul).
Het resultaat van deze filter moet worden gekopieerd naar een nieuwe sheet (identieke layout van de sheet en ook in tabelvorm)
De tabel en het nieuwe tabblad moeten de naam van de filterwaarde krijgen.

Het aantal rijen en ook de verschillende users zijn telkens verschillend.
Manueel lukt me dat, maar kan het ook geautomatiseerd (want deze oefening moet wekelijks worden herhaald en is uitgebreider dan het voorbeeld)

Ik dacht aan
- tabblad kopiëren
- filter opzetten
- weggefilterde rijen verwijderen
- tabblad en tabel hernoemen
- terug naar master-sheet en herhalen

Elke aparte handeling kan ik uitvoeren, maar ik weet niet hoe een loop te maken met alle mogelijke filterwaarden en deze mee te nemen voor de hernoeming.


Alvast bedankt voor support
 

Bijlagen

  • Tabel met AutoFilter en kopieer naar Nieuw Tabblad.xlsb
    16,8 KB · Weergaven: 30
variant op een vraag die al tig keer gesteld is
Code: 
Sub filteren()
    With Sheets("master")
        Set tbl = .ListObjects(1).Range                              'je tabel
        .Range("AA1").Resize(100, 3).ClearContents                   'uitvoerbereik leegmaken
        tbl.Columns(2).AdvancedFilter xlFilterCopy, , .Range("AB1"), True    'unieke usernames kopieren
        sn = .Range("AB1").CurrentRegion                             'inlezen unieke usernames

        For i = 2 To UBound(sn)                                      'usernames aflopen
            If Len(sn(i, 1)) Then                                    'niet leeg
                If Evaluate("not(isref(" & sn(i, 1) & "!A1))") Then  'werkblad bestaat nog niet
                    tbl.AutoFilter                                   'eventuele autofilter uitzetten
                    tbl.AutoFilter 2, sn(i, 1)                       'filteren op username
                    Sheets.Add(, Sheets(Sheets.Count)).Name = Format(sn(i, 1))    'nieuw tabblad aanmaken
                    tbl.SpecialCells(xlVisible).Copy Sheets(sn(i, 1)).Range("A1")    'gefilterde tabel doorkopieëren
                Else
                    MsgBox "werkblad " & sn(i, 1) & " bestaat al", vbCritical    'foutje bedankt
                End If
            End If
        Next
        tbl.AutoFilter                                               'tabel filter uitzetten
    End With
End Sub
 
Andere methode:
Code: 
Sub hsv()
Dim sv, i As Long, sh As Worksheet, obj As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Sheets("master").ListObjects(1)
sv = .DataBodyRange
Set obj = CreateObject("scripting.dictionary")
 For i = 1 To UBound(sv)
  If Not obj.exists(sv(i, 2)) Then
    On Error Resume Next
       Sheets(sv(i, 2)).Delete
       Sheets.Add(, Sheets(Sheets.Count)).Name = sv(i, 2)
          obj(sv(i, 2)) = sv(i, 2)
         .Range.AutoFilter 2, sv(i, 2)
        Union(.HeaderRowRange, .DataBodyRange).Copy Sheets(sv(i, 2)).Cells(1)
       Sheets(sv(i, 2)).ListObjects.Add(xlSrcRange, Sheets(sv(i, 2)).Cells(1).CurrentRegion, , xlYes).Name = sv(i, 2)
    End If
  Next i
 .Range.AutoFilter 2
End With
End Sub
 
Laatst bewerkt:
Dankjewel allebei voor de reply ; hiermee kan ik verder.

Versie van HSV maakt andere tabel
Versie van COW18 kopieert de data

Beide zijn bruikbaar.

Alleen worden de gegevens nu als waarde geplakt en verlies ik eventuele formules.
Hoe kan ik dat vermijden bij de copy?

Sommige formules verwijzen naar parameters die boven de tabel staan, en hier worden nu enkel de gegevens uit de tabel overgezet.
Vandaar dat ik dacht dat het nodig zou zijn om het tabblad te kopiëren en dan pas de filtering op te zetten...?
 
Laatst bewerkt:
ik had aanvankelijk een probleempje, omdat bij het verwijderen van listrows, de ganse rij ook verwijderd werd en dat zou vermoedelijk de volgende opmerking van jou geweest zijn.
Dus deze verwijdert alleen de listrow en de rest van de rij blijft ongewijzigd.
Code: 
Sub filteren()
    Dim shCopy As Worksheet, tbl
    Set shCopy = Sheets("master")
    With shCopy
        Set tbl = .ListObjects(1).Range                              'je tabel
        .Range("AA1").Resize(100, 3).ClearContents                   'uitvoerbereik leegmaken
        tbl.Columns(2).AdvancedFilter xlFilterCopy, , .Range("AB1"), True    'unieke usernames kopieren
        sn = .Range("AB1").CurrentRegion                             'inlezen unieke usernames

        Application.DisplayAlerts = False
        For i = 2 To UBound(sn)                                      'usernames aflopen
            If Len(sn(i, 1)) Then                                    'niet leeg
                If Evaluate("not(isref(" & sn(i, 1) & "!A1))") Then  'werkblad bestaat nog niet
                    'tbl.AutoFilter                                   'eventuele autofilter uitzetten
                    'tbl.AutoFilter 2, sn(i, 1)                       'filteren op username
                    shCopy.Copy After:=Sheets(Sheets.Count)
                    With ActiveSheet
                        .Name = Format(sn(i, 1))                     'nieuw tabblad aanmaken
                        With .ListObjects(1)
                            .Range.AutoFilter
                            .Range.AutoFilter 2, sn(i, 1)            'filteren op die waarden
                            Set c = .DataBodyRange.Columns(1).SpecialCells(xlVisible)    'zichtbare cellen mogen straks blijven staan
                            .Range.AutoFilter                        'filter uitzetten
                            For j = .ListRows.Count To 1 Step -1     'van achter naar voor lopen
                                If Intersect(c, .ListRows(j).Range) Is Nothing Then .ListRows(j).Delete
                            Next
                        End With
                    End With
                Else
                    MsgBox "werkblad " & sn(i, 1) & " bestaat al", vbCritical    'foutje bedankt
                End If
            End If
        Next
        Application.DisplayAlerts = False

        tbl.AutoFilter                                               'tabel filter uitzetten
    End With
End Sub
 
Laatst bewerkt:
Dynamischer alternatief:

Code: 
Sub M_snb()
  Blad1.Columns(2).SpecialCells(2).AdvancedFilter 2, , Blad1.Cells(1, 40), -1
  sn = Blad1.Cells(1, 40).CurrentRegion
  Blad1.Cells(1, 40).CurrentRegion.Clear

  c00 = Replace("OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Data Source=~;Jet OLEDB:Engine Type=35", "~", ThisWorkbook.FullName)
      
  For j = 2 To UBound(sn)
    With Sheets.Add(, Sheets(Sheets.Count))
      .Name = sn(j, 1)
      With .ListObjects.Add(0, c00, , , .Range("$A$1")).QueryTable
        .CommandText = "SELECT * FROM `Master$` where User='" & sn(j, 1) & "'"
        .Refresh False
      End With
    End With
  Next
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan