filteren van bestand op naam

tristi · 23 dec 2012

Beste forumleden,

Ik dien op de basissheet (werkblad) de groepsverantwoordelijken te selecteren en de desbetreffende rijen te kopiëren naar hun eigen werkblad.
Via een opgenomen macro heb ik dit gedaan door de autofilter toe te passen en dit werkt (als mijn bestand uit 350 deelnemers gaat kopieer ik bv voor een groepsverantwoordelijke een 60 rijen enz enz).

Alleen is dit slechts van toepassing op de huidige maand doch wanneer de volgende maand er nieuwe deelnemers bijkomen klopt dit verhaaktje niet meer en ontbreken er medewerkers op de sheet van de groepsverantwoordelijken doordat de macro geseltecteerd heeft op de vorige maand en dus de rijen min of meer vast liggen

Nu heb ik wel al opgezocht dat dit kan opgelost worden door het volgende in de macro te zetten : Range(Selection, Selection.End(xlDown)).Select

Het lukt mij echter niet om dit tot een goed eind te brengen.

Kunnen jullie mij verder helpen aub.

Alvast bedankt !!!!

Hier een kopie van de opgenomen macro

Code:

Sheets("werkblad").Select
ActiveSheet.Range("$AA$16:$AA$820").AutoFilter Field:=1, Criteria1:= _
"afwezig"
Range("B36:X1101").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("afwezigheid").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Cut Destination:=Range("B18:X311")
Range("B18:X311").Select
ActiveWindow.SmallScroll Down:=-18
Range("F9").Select
Sheets("werkblad").Select
ActiveSheet.Range("$AA$16:$AA$820").AutoFilter Field:=1, Criteria1:= _
"Collect"
Range("B45:X1074").Select
Selection.Copy
Sheets("Collect").Select
Range("B18").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-9
Range("D8").Select

HSV · 24 dec 2012

Doe je bestandje er eens bij als bijlage als je wil.

tristi · 24 dec 2012

Beste HSV,

Het lukt mij niet op een bestand bij te voegen (bestand is 1Mb)
Andere oplossing ?

HSV · 24 dec 2012

Zippen of Rarren.
Maar een klein voorbeeldbestandje met een paar bladen is meestal genoeg.

tristi · 24 dec 2012

Nog eens proberen

HSV · 24 dec 2012

Het bestand is beschadigd, en kan niet worden geopend.

tristi · 25 dec 2012

Beste HSV,

Misschien helpt een ZIP bestand.

PS : Prettige kerstdagen

HSV · 25 dec 2012

Met wat verzamelen van wat codes, ben ik tot dit resultaat gekomen.

De code doet:

Verwijderen van blad 2 t/m aantal bladen.
Unieke namen verzamelen.
Nieuw blad aanmaken van unieke naam.
Kopiëren van range B10:X17 naar nieuw blad.
Filteren op unieke naam.
Filterrijen wegschrijven naar nieuw tabblad.

Code:

Sub hsv()
Dim cl As Range
Dim oDic As Object
Dim vKey As Variant
Dim lngKey As Long
Dim v As String
Dim Rng As Range
Dim i As Long
Set oDic = CreateObject("Scripting.Dictionary")
    
    Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
  If i > 1 Then Sheets(i).Delete
Next
Application.ScreenUpdating = False
 With Sheets("werkblad")
  Set Rng = .Range("AA18:AA" & .Cells(Rows.Count, 27).End(xlUp).Row)
     For Each cl In Rng
       With oDic
        .CompareMode = vbTextCompare
          v = cl.Value
    If Not .exists(v) Then .Add v, 1
         End With
     Next cl
   With oDic
ReDim vkeys(1 To .Count)
    For Each vKey In .Keys  
      Sheets.Add , Sheets(Sheets.Count)
       ActiveSheet.Name = vKey
With Sheets("werkblad")
    .Range("B17:AA" & .Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter 26, vKey
    .Range("B10:X17").Copy Sheets(vKey).Range("B3")
    .AutoFilter.Range.Offset(1).Resize(, 23).SpecialCells(12).Copy Sheets(vKey).Range("B11") '.Cells(Rows.Count, 1).End(xlUp).Offset(1)
  Sheets(vKey).Columns.AutoFit
     .Range("B17:AA" & .Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
       End With
      Next vKey
    End With
   Set oDic = Nothing
 End With
Application.DisplayAlerts = True
End Sub

tristi · 26 dec 2012

Beste HSV,

Ik heb uw code in een werkbook geplaatst en na het laten uitvoeren van de marco stopt hij met de melding "typen komen niet overeen met elkaar"

Hieronder tot waar de macro stopt en terug springt naar "With oDic".

Wat doe ik fout?

Code:

Sub hsv()
Dim cl As Range
Dim oDic As Object
Dim vKey As Variant
Dim lngKey As Long
Dim v As String
Dim Rng As Range
Dim i As Long
Set oDic = CreateObject("Scripting.Dictionary")
    
    Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
  If i > 1 Then Sheets(i).Delete
Next
Application.ScreenUpdating = False
 With Sheets("werkblad")
  Set Rng = .Range("AA18:AA" & .Cells(Rows.Count, 27).End(xlUp).Row)
     For Each cl In Rng
       With oDic
        .CompareMode = vbTextCompare
          v = cl.Value
    If Not .exists(v) Then .Add v, 1
         End With
     Next cl

Warme bakkertje · 26 dec 2012

Nog een beetje ballast minder.

Code:

Option Explicit
Sub hsv()
Dim oDic As Object, ws As Worksheet, i As Long, cl As Range, vKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
Set ws = Sheets("werkblad")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    For i = Sheets.Count To 2 Step -1
        If i > 1 Then Sheets(i).Delete
    Next
    For Each cl In ws.Range("AA18:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
    Next cl
    With oDic
        For Each vKey In .Keys
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Name = vKey
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter 26, vKey
                ws.Range("B10:X17").Copy .Range("B3")
                ws.AutoFilter.Range.Offset(1).Resize(, 23).SpecialCells(12).Copy .Range("B11")
                .Columns.AutoFit
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
            End With
        Next vKey
    End With
    Set oDic = Nothing: Set ws = Nothing
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

tristi · 26 dec 2012

Dag Rudi,

IK heb ook uw code ingebracht en krijg dezelde melding en stop en kom in een soort loop terecht van volgende lijnen

Code:

With oDic
.CompareMode = vbTextCompare
v = cl.Value
If Not .exists(v) Then .Add v, 1
End With
Next cl

Het enige wat ik nog zie in mijn bestand is het werkblad .
Enig idee?

Alvast bedankt voor de hulp^!!!

Warme bakkertje · 26 dec 2012

Dat is niet mijn code, want ik had er dit van gemaakt.

Code:

    For Each cl In ws.Range("AA18:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
    Next cl

tristi · 26 dec 2012

Rudi,

Dit is het gedeelte dat hij loopt en dat springt hij terug naar de 5e laatste lijn (lijn with oDic)

Ook hier is het "werkblad" het enige zichtbare sheet in het bestand.

Code:

Sub hsv()
Dim oDic As Object, ws As Worksheet, i As Long, cl As Range, vKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
Set ws = Sheets("werkblad")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    For i = Sheets.Count To 2 Step -1
        If i > 1 Then Sheets(i).Delete
    Next
    For Each cl In ws.Range("AA18:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
    Next cl

Mvr,
Ria

Warme bakkertje · 26 dec 2012

Hoe wordt kolom AA gevuld ?
Ik heb in je originele bestand gezien dat er in kolom AA cellen met #N/B tussen staan, en daar loopt de code op vast.

tristi · 26 dec 2012

Rudi,

Ik heb alle "NB# verwijderd en zal ze volgende maand bij de groep 'afwezigen" plaatsen en inderdaad alle bladen worden nu opgemaakt en is mijn probleem van die autofilter opgelost, waarvoor hartelijk bedankt !!!!

Nu gezien dit een kopie (waarden en opmaak) was van mijn werkelijk bestand kon U en HSV uiteraard niet zien dat alle verantwoordelijken hun eigen totalen verkregen en niet het volledige eindtotalen zoals nu.

Dat ik op de kopies geen titels krijg zou ik nu zo erg niet vinden doch in mijn originele bestand staat er bij elke verantwoordelijk een knop aangemaakt "hoofmenu" waarnee zij terug naar de startpagina gaan.

Kan dit nog via een aanpassing van deze macro?

MVG,
Ria

huijb · 26 dec 2012

@tristi Code dient tussen de codetags geplaatst te worden. Hiermee is het beter leesbaar voor de helpers. Zie ook hier http://www.helpmij.nl/forum/showthr...-de-helpers-in-deze-sectie-van-dienst-te-zijn

tristi · 26 dec 2012

Beste Huijb,

Bedankt voor deze info !!!

Mvg,
Ria

HSV · 26 dec 2012

Hallo Ria,

Bedankt voor het inkorten Rudi.
Volgens mij ben ik zo weer een beetje bij met de code.

Geen kolomkoppen.
Verwijder de rode tekst of zet er een apostrof voor, en verander zoals de bruinachtige range.

Code:

Sub hsv()
Dim oDic As Object, ws As Worksheet, i As Long, cl As Range, vKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
Set ws = Sheets("werkblad")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    For i = Sheets.Count To 2 Step -1
        If i > 1 Then Sheets(i).Delete
    Next
    For Each cl In ws.Range("AA18:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
     Next cl
With oDic
        For Each vKey In .Keys
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Name = vKey
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter 26, vKey
            [COLOR=#ff0000]'ws.Range("B10:X17").Copy .Range("B3")
[/COLOR]               ws.AutoFilter.Range.Offset(1).Resize(, 23).SpecialCells(12).Copy [COLOR=#8b4513].Range("B3")
[/COLOR]               .Columns.AutoFit
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
            End With
        Next vKey
    End With
 Set oDic = Nothing: Set ws = Nothing
   .DisplayAlerts = True
   End With
End Sub

Voor een evt. knop moet ik maar eens uitvogelen, maar misschien heeft Rudi daar direct een antwoord op.

Warme bakkertje · 26 dec 2012

Direct is een groot woord, maar het is er dan toch gekomen.:d

Code:

Sub hsv()
Dim oDic As Object, ws As Worksheet, i As Long, cl As Range, vKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
Set ws = Sheets("werkblad")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    For i = Sheets.Count To 2 Step -1
        If i > 1 Then Sheets(i).Delete
    Next
    For Each cl In ws.Range("AA18:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
    Next cl
    With oDic
        For Each vKey In .Keys
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Name = vKey
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter 26, vKey
                ws.AutoFilter.Range.Offset(1).Resize(, 23).SpecialCells(12).Copy .Range("B3")
               .Columns.AutoFit
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
                Set obj = .OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
                        Link:=False, DisplayAsIcon:=False, Left:=20, Top:=5, Width:=100, Height:=20)
            End With
            obj.Name = "Hoofdmenu"
            Sheets(vKey).OLEObjects(1).Object.Caption = "Hoofdmenu"
            With ActiveWorkbook.VBProject.VBComponents(Sheets(vKey).CodeName).CodeModule
                .insertlines .CountOfLines + 1, "Sub Hoofdmenu_Click()" & vbCrLf & "call Startblad" & vbCrLf & "End Sub"
            End With
        Next vKey
    End With
    Set oDic = Nothing: Set ws = Nothing
   .DisplayAlerts = True
   .ScreenUpdating = True
End With
End Sub

Sub Startblad()
    Application.Goto Sheets("Werkblad").Range("A1"), True 'aanpassen naar wens
End Sub

HSV · 26 dec 2012

Een commandbutton invoegen lukte, maar ik kreeg er vooralsnog geen code aan gekoppeld.
Ik ben daarom overgestapt naar een shape.

Mooi code Rudi.
Ik zal het eens bestuderen waar ik ben blijven hangen.

De shape_code:

Code:

Sub hsv()
Dim oDic As Object, ws As Worksheet, i As Long, cl As Range, vKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
Set ws = Sheets("werkblad")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    For i = Sheets.Count To 2 Step -1
        If i > 1 Then Sheets(i).Delete
    Next
    For Each cl In ws.Range("AA18:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
     Next cl
With oDic
        For Each vKey In .Keys
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Name = vKey
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter 26, vKey
            'ws.Range("B10:X17").Copy .Range("B3")
                ws.AutoFilter.Range.Offset(1).Resize(, 23).SpecialCells(12).Copy .Range("B3")
                
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
              .Columns.AutoFit
              ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 360.75, 3.75, 133.5, 22.5).Select
                 Selection.OnAction = "hsv_2"
                 Selection.Characters.Text = "Naar werkblad"
              Application.Goto .Range("A1")
            End With
        Next vKey
    End With
 Set oDic = Nothing: Set ws = Nothing
   .DisplayAlerts = True
   End With
End Sub

Code:

Sub hsv_2()
 Application.Goto Sheets("werkblad").Range("A1")
End Sub

filteren van bestand op naam

Gebruiker

Inventaris

Gebruiker

Inventaris

Gebruiker

Bijlagen

Inventaris

Gebruiker

Bijlagen

Inventaris

Bijlagen

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Supermoderator

Gebruiker

Inventaris

Meubilair

Inventaris

Wij waarderen jouw privacy