filteren van bestand op naam

Status
Niet open voor verdere reacties.
Hey Rudi,

Hij geeft een compileerfout aan met de melding : een variable is niet gedefinieerd.

Nog een vraagje : mijn bestand bestaat uit meer de u gekende sheets oa data, input gegevens enz.
Plaats ik al deze tabbladen voor het werkblad? of gaan deze door de macro ook allemaal verdwijnen.

Mvg,
Ria
 
Zoals steeds zijn er meerdere wegen die naar Rome leiden. :thumb:
 
Hallo Ria,

Declareer zo als rode tekst.
Code: 
Dim oDic As Object, ws As Worksheet, i As Long, cl As Range, vKey As Variant, [COLOR=#ff0000]obj As Object[/COLOR]

2). Ja, het tweede blad t/m de laatste bladen worden verwijderd.
Als je de eerste 4 wil laten staan?
Code: 
For i = Sheets.Count To 4 Step -1
       Sheets(i).Delete
   Next
 
Hey Rudi en HSV,

Ik heb beide macro's geprobeerd en deze van HSV loopt goed en Rudi bij uw laatste macro krijg ik de melding 400 en stopt hij na één blad te hebben aangemaakt.

Ik ga dit alles morgen nu eens trachten te plaatsen in mijn orgineel bestand en zien waar ik eindig. :)
Voor vandaag stop ik er mee (de macro's dansen voor mijn ogen :d

Jongens toch al reeds verschrikkelijk bedankt om mij deze hulp te willen verlenen.

Ik laat je dus morgen zeker iets weten !!!

Mvg,
Ria
 
Het is altijd moeilijker als je niet met het originele bestand kan werken.
Mijn macro is gebaseerd op het laatste bestand van Harry uit Post#8 en daar werkt hij prima in.
Als de code van Harry wel doet wat je wil, dan gebruik je toch gelijk de zijne. :)
 
Rudi,

Kan het iets zijn met de activeX-besturingselementen.
Een toepassing hier of daar in Excel.
Kan zo snel niets iets bedenken welke instelling.
Ik zal ook eens zoeken.
 
Hallo Rudi, Harry,

De macro loopt correct.
Indien ik in het werknlad de SOM functie plaats dan krijgen de aangemaakte sheets hun eigen berekening dus één woord prachtig.

Ook heb ik toch een titel aangemaakt en dus de cellen in de macro aangepast.
Alleen het visuele aspect is vatbaar voor verbetering maw
In de aangemaakte sheets wordt gewerkt met een autofit voor de kolommen en dit is OK alleen kolom A zou ik bv op 2 willen ipv 8.43 indien dit niet gaat zal ik kolom A verwijderen.
Maar de rijhoogten die staan nu op 24 in de aangemaakte sheets indien dit mogelijk is zou ik dit idem willen zoals in het werkblad nl 15.
Hoe kan ik die Commandbutton laten verschijnen in cellen B2-C2 ipv in het midden van het blad.

Gezien ik werk met laptop van het werk waarin een beveiliging staat dat ik niet kan downloaden of uploaden kan ik spijtig genoeg u geen vb geven hoe die sheets er nu uitzien.
De bijlage die ik in vorige heb aangemaakt werd via de PC van een vriendin gedaan en die vind ik voor het ogenblik niet.:D
 
Hallo Ria,

De rode regels aanvullen.
Code: 
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
               [COLOR=#ff0000].Columns(1).ColumnWidth = 2
               .UsedRange.RowHeight = 15[/COLOR]

De commandbutton van Rudi werkt nu wel? :thumb:
Verander in de code de "Left" & "Width" in een ander getal.
Code: 
Set obj = .OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
                        Link:=False, DisplayAsIcon:=False, Left:=[COLOR=#ff0000]20[/COLOR], Top:=5, Width:=[COLOR=#ff0000]100[/COLOR], Height:=20)
 
Beste Harry,

Ik heb de macro in mijn origineel bestand geplakt (onder mijn opgenomen macro) doch hij loopt vast.

In ons vb bestand werkt alles normaal en ik heb nagekeken of er een #NB# was doch dit is niet het geval

code
Code: 
Sub sort_TL()
'
' sort_TL Macro
'

'
    Sheets("input").Select
    Range("A15:A1098").Select
    Selection.Copy
    Sheets("werkblad").Select
    Range("B18").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("B18:X820").Select
    Selection.Copy
    Sheets("Aalst Mail").Select
    Range("B18").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-9
    Range("D7").Select
    Sheets("werkblad").Select
    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 7 Step -1
        If i > 1 Then Sheets(i).Delete
    Next
    For Each cl In ws.Range("AA14:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row)
        [COLOR="#FF0000"]With oDic
            .CompareMode = 1
            If Not .exists(cl.Value) And cl.Value <> "" Then .Add cl.Value, 1
        End With
     Next cl[/COLOR]With oDic
        For Each vKey In .Keys
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Name = vKey
                ws.Range("B13:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter 26, vKey
                ws.Range("B1:X13").Copy .Range("B1")
                ws.AutoFilter.Range.Offset(1).Resize(, 23).SpecialCells(12).Copy .Range("B14")
                .Columns.AutoFit
                .Columns(1).ColumnWidth = 2
                .UsedRange.RowHeight = 15
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
              
              ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 20, 5, 133.5, 22.5).Select
                 Selection.OnAction = "hsv_2"
                 Selection.Characters.Text = "Hoofdmenu"
              Application.Goto .Range("A1")
            End With
        Next vKey
    End With
 Set oDic = Nothing: Set ws = Nothing
   .DisplayAlerts = True
   End With
End Sub
Sub hsv_2()
 Application.Goto Sheets("hoofdmenu").Range("A1")
End Sub

    
    Sheets("startpagina").Select
    Columns("N:R").Select
    Selection.EntireColumn.Hidden = True
    Range("M12").Select
End Sub
Sub werkknop()
'
' werkknop Macro
'

'
    Columns("M:S").Select
    Selection.EntireColumn.Hidden = False
End Sub
 
Hallo Ria,

Loopt het vast op het rode gedeelte?
Kun je het bestand uploaden, of staat er informatie in die je liever niet op het forum zet.
Ik heb de mijne licht aangepast zonder select van de shape.
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")
                
                ws.Range("B17:AA" & ws.Cells(Rows.Count, 27).End(xlUp).Row).AutoFilter
              .Columns.AutoFit
              .Columns(1).ColumnWidth = 2
              .UsedRange.RowHeight = 15
              With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 19, 3.75, 100, 22.5)
                 .OnAction = "hsv_2"
                 .TextFrame.Characters.Text = "Naar werkblad"
              End With
            End With
        Next vKey
    End With
 Set oDic = Nothing: Set ws = Nothing
   .DisplayAlerts = True
   End With
End Sub
Sub hsv_2()
 Application.Goto Sheets("werkblad").Range("A1")
End Sub
 
Harry,

Hij loopt inderdaad vast op het rode gedeelte. Hij verwijderd de sheets en dan zou hij normaal nieuwe sheets moeten aanmaken en dat gebeurd dus niet hij maakt steeds een loop.

Nu het origineel bestand is ongeveer 1MB en zelfs via zip blijft hij over de max van 100KB gaan.
Ik zou er geen problemen mee hebben met de info van mijn bestanden ik zou enkel de namen wijzigen (dit omdat ze mij lieten weten nooit geen namen op internet te zetten).
Ik wel dit eventueel wel persoonlijk naar jou sturen maar denk ook niet dat men hier privé emailadres mag neerzetten :)

Mvg,
Ria
 
Harry,

Nogmaals geprobeerd met de macro maar hij blijft op het rode gedeelte vastlopen.

Ik zal morgen trachten mijn bestand te verlichten en alsnog te oploaden als pc vriendin beschikbaar is.

Het zou spijtig zijn moesten we nu stranden :(

Mvr,
Ria
 
Zet je complete bestand op mijnbestand.nl en plaats hier dan de link ernaartoe.
 
Rudi, Harry,

Het zal een werkje voor dit weekend worden, vandaag geen tijd gehad om mijn pc te openen.

Tot later !!

Mvg,
Ria
 
Beste Rudi en Harry,

Gezien de vele foutmeldingen heb ik mijn bestand helemaal herbegonnen en dit in functie van de door jullie gemaakte macro
Nadat ik hiermee klaar was kreeg ik nog steeds dezelfde foutmelding op jullie macro.

Deze foutmelding heb ik zopas gevonden (er stond nog steeds een button autofilter in mijn werkblad). ik heb deze verwijderd en wonder boven wonder alles werkte :thumb:
Ik heb de gegevens van de laatste 3 maanden verwerkt en alles verliep vlekkeloos.

Woorden schieten mij tekort om jullie te danken voor de hulp en bijstand die jullie hebben verleend.

Door het vele zoekwerk op het internet en ook op dit forum heb ik uiteraard veel geleerd en zal zeker een vaste bezoeker worden.

Nogmaals bedankt !!!!!!!!

Mvg,
Ria
 
Laatst bewerkt:
Graag gedaan Ria.

Helaas kon ik niet inloggen vandaag.
Ik ben overgegaan op een nieuw provider, die de boel vandaag aan het installeren was.

Succes ermee.
 
@ Harry
Bezorg je mij dan eens je nieuwe emailadres. :thumb:

@ Ria
Hoe meer je er mee bezig bent, hoe leuker het wordt :D
 
Laatst bewerkt:
Zeker Rudi, zolang ik nog van je leer doe ik dat graag. :D
Dit was voor mij ook weer leerzaam.
Het is onderweg.

Ik ga nu het feestgebruis in.
Een goede jaarwisseling gewenst allebeide.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan