• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Gegevens filteren op basis van criteria en verplaatsen naar een ander werkblad

Status
Niet open voor verdere reacties.
J

jan07

Gebruiker
Lid geworden
9 nov 2006
Berichten
10
Ben bezig om uit een grote hoeveelheid records in excel op een handige manier selecties te maken.

Het bestand bestaat uit entiteiten met de bijbehorende attributen de entiteitcode is uniek

De benodigde attributen selecteer ik middels een "x" zie de kolom M vervolgens kan ik ze met de toegepaste filter bij elkaar krijgen.

Daarnaast heb ik een aantal kolommen gedefinieerd naast Templates. Ook hier "x" ik aan welke entiteiten ik aan de templates wil koppelen.

Nu is het de bedoeling dat ik met behulp van een dropdown box een keuze kan maken uit een van de aanwezige template kolommen. Door dan akkoord te geven zouden de geslecteerde entiteiten met de bijbehorende attributen naar een andere corresponderende werkmap gekopieerd moeten worden.

Voor de goede orde alleen de inhoud van de kolom b en d wil ik naar de corresponderende werkmap kopieeren.

Ik ben hier al heel lang mee bezig om het met formules te proberen op te lossen maar daar kom ik niet uit. En mijn kennis van VBA zit nog in het beginstadium. Het moet volgens mij met VBA op te lossen zijn

Wie helpt mij het zou enorm veel tijd besparen want nu wordt het knippen en plakken met alle gevolgen van dien.

Voor de duidelijkheid heb ik een gedeelte van de records in een rar bestand bijgevoegd.
 

Bijlagen

jan07,

Hoe komt de data in kolom D eruit te zien? is dat voor rij 425: v1mawk?
En wat bedoel je met een dropdownbox? is dit een knop waarop je drukt en die kopieerd al je data naar een ander tabblad? of wordt dit een userform?


Groet,
Ferenc

ps.
voor kolom D kan je de volgende formule gebruiken:
Code: 
=TEKST.SAMENVOEGEN(TEKST.SAMENVOEGEN(ALS(M425="x";"V";"");ALS(N425="x";"R";"");ALS(O425<>"";O425;""));ALS(W425="x";"M";"");ALS(X425="x";"A";"");ALS(Y425="x";"W";"");TEKST.SAMENVOEGEN(ALS(Z425="x";"K";"");ALS(AA425="x";"L";"")))
Niet geheel netjes ingevuld maar het doet het werk.
Ben alleen bang dat je een groot bestand krijgt als je deze gaat gebruiken in al je regels.

ps2.
Mijn formule kennis is niet zo heel groot :(
vandaar, maar misschien leren we op deze manier alle twee hoe het kan :)
 
Laatst bewerkt:
Jan07,

Niet volledig wat je zou willen:
Code: 
Sub getallen()
Dim c As Range

Application.ScreenUpdating = False

LegeregelBlad1 = Sheets("Blad1").Range("B" & Rows.Count).End(xlUp).Row + 1

For Each c In Sheets("Blad1").Range("B2:B" & LegeregelBlad1)
    If c <> "" Then
        o = IIf(Sheets("Blad1").Range("M" & c.Row) = "x", "V", "")
        p = IIf(Sheets("Blad1").Range("N" & c.Row) = "x", "R", "")
        q = IIf(Sheets("Blad1").Range("O" & c.Row) <> "", Sheets("Blad1").Range("O" & c.Row), "")
        r = IIf(Sheets("Blad1").Range("W" & c.Row) = "x", "M", "")
        s = IIf(Sheets("Blad1").Range("X" & c.Row) = "x", "A", "")
        t = IIf(Sheets("Blad1").Range("Y" & c.Row) = "x", "W", "")
        u = IIf(Sheets("Blad1").Range("Z" & c.Row) = "x", "K", "")
        v = IIf(Sheets("Blad1").Range("A" & c.Row) = "x", "L", "")
        
        LegeregelBlad2 = Sheets("Blad2").Range("A" & Rows.Count).End(xlUp).Row + 1
        Sheets("Blad2").Range("A" & LegeregelBlad2) = c.Value
        Sheets("Blad2").Range("B" & LegeregelBlad2) = o & p & q & r & s & t & u & v
        
    End If
Next

Application.ScreenUpdating = True

End Sub

In ieder geval een opzet om verder mee te gaan.


Groet,
Ferenc
 
Laatst bewerkt:
Demeter zei:
jan07,

Hoe komt de data in kolom D eruit te zien? is dat voor rij 425: v1mawk?
En wat bedoel je met een dropdownbox? is dit een knop waarop je drukt en die kopieerd al je data naar een ander tabblad? of wordt dit een userform?


Groet,
Ferenc

ps.
voor kolom D kan je de volgende formule gebruiken:
Code: 
=TEKST.SAMENVOEGEN(TEKST.SAMENVOEGEN(ALS(M425="x";"V";"");ALS(N425="x";"R";"");ALS(O425<>"";O425;""));ALS(W425="x";"M";"");ALS(X425="x";"A";"");ALS(Y425="x";"W";"");TEKST.SAMENVOEGEN(ALS(Z425="x";"K";"");ALS(AA425="x";"L";"")))
Niet geheel netjes ingevuld maar het doet het werk.
Ben alleen bang dat je een groot bestand krijgt als je deze gaat gebruiken in al je regels.

ps2.
Mijn formule kennis is niet zo heel groot :(
vandaar, maar misschien leren we op deze manier alle twee hoe het kan :)
Klik om te vergroten...


Bedankt voor je reactie ben zelf ook al behoorlijk aan het kloojen geweest met formules.
en je hebt gelijk dan wordt het bestand veel te groot, het oorspronkelijke bestand zonder formules is al 10mb

Daarom dacht ik dat de oplossing in VBA gezocht moest worden, maar ja dan houdt het voor mij al snel op, kan het wel volgen maar niet zelf verzinnen.

Zal proberen wat duidelijker te zijn met wat ik wil, daarvoor is het handig als de toegepaste filtering even wordt uitgezet.

Als je naar rij 558 gaat dan zie je hoop ik duidelijker de bedoeling

In de kolom B staat de entiteit PP dit is een unieke kode
Bij templates staat aangekruist dat deze entiteit nodig is voor de templates M,A,W en K
Als ik de entiteit nodig heb dan is het de bedoeling dat de aangekruiste attributen in kolom M (kolomnaam V)de bijbehorende waarden uit de kolommen B en D ophaalt en kopieert naar de (nog te maken) werkbladen M,A,W en K. Volgens mij moet dat kunnen op basis van de unieke entiteit code in dit geval PP en het kruisje uit kolom M, maar ja doe het maar eens.

De kopieerslag zou ik willen starten met een zogenaamde Combobox.

Ben heel benieuwd naar de reacties en alvast bedankt voor de te nemen moeite
 
Ferenc

Ben benieuwd hoever ik met je opzet kom. Leuk om te constateren dat men het probleem direct oppakt.

Ga er direct mee aan de gang en kom er op terug

Groet,

Jan
 
Ferenc,

Kom nog niet verder met je script hij komt met een foutmelding op deze regel

LegeregelBlad1 = Sheets("Blad1").Range("B" & Rows.Count).End(xlUp).Row + 1

meldt het als compileerfout een variabele is niet gedeclareerd. Kun je me ook zeggen wat je precies met die legeregelBlad1 wil bereiken?

Groet,

Jan
 
jan07 zei:
Leuk om te constateren dat men het probleem direct oppakt.
Klik om te vergroten...

Dat is het principe van een forum zoals dit hé :cool:

Ik zal mij zo dadelijk ook eens bezighouden met je vraag, hopelijk breng ik ons allen hier iets bij.

Wigi
 
Wigi zei:
Dat is het principe van een forum zoals dit hé :cool:

Ik zal mij zo dadelijk ook eens bezighouden met je vraag, hopelijk breng ik ons allen hier iets bij.

Wigi
Klik om te vergroten...

Ik ben benieuwd naar je antwoord, alleen ik ga nu naar mijn bedje is toch al weer later dan ik dacht.

Groetjes,

Jan
 
Jan07,

Denk dat ik wat te voorbarig ben geweest met mijn code. Maar is meer om aan te geven hoe je de juiste variabelen te pakken kan krijgen.
Waar je ze wil plaatsen moet je zelf weten :).

Regels klopten nie thelemaal, denk dat het volgende voorbeeld wel zou moeten werken (heb zelf niks getets):
Code: 
Sub getallen()
Dim c As Range
Dim laatsteregelBlad1 as Range
Dim laatsteregelBlad2 as Range

Application.ScreenUpdating = False

LaatsteregelBlad1 = Sheets("Blad1").Range("B" & Rows.Count).End(xlUp).Row

For Each c In Sheets("Blad1").Range("B2:B" & LegeregelBlad1)
    If c <> "" Then
        o = IIf(Sheets("Blad1").Range("M" & c.Row) = "x", "V", "")
        p = IIf(Sheets("Blad1").Range("N" & c.Row) = "x", "R", "")
        q = IIf(Sheets("Blad1").Range("O" & c.Row) <> "", Sheets("Blad1").Range("O" & c.Row), "")
        r = IIf(Sheets("Blad1").Range("W" & c.Row) = "x", "M", "")
        s = IIf(Sheets("Blad1").Range("X" & c.Row) = "x", "A", "")
        t = IIf(Sheets("Blad1").Range("Y" & c.Row) = "x", "W", "")
        u = IIf(Sheets("Blad1").Range("Z" & c.Row) = "x", "K", "")
        v = IIf(Sheets("Blad1").Range("A" & c.Row) = "x", "L", "")
        
        LaatsteregelBlad2 = Sheets("Blad2").Range("A" & Rows.Count).End(xlUp).Row 
        Sheets("Blad2").Range("A" & LegeregelBlad2) = c.Value
        Sheets("Blad2").Range("B" & LegeregelBlad2) = o & p & q & r & s & t & u & v
        
    End If
Next

Application.ScreenUpdating = True

End Sub

Met de laatsteregel wil ik het bereik bepalen zonder dat ik te veel lege regels door laat lopen. De laatsteregel zoekt de laatst gevulde regel op blad1 en op blad2.

Kijk er morgen op kantoor nog wel naar. Je vraag stelling is mij nu wat duidelijker.

Succes en tot morgen.
Ferenc
 
Kan het niet laten, het grijpt me steeds dichter om mijn strot.

Voor de M-serie kom in de buurt van:
Code: 
For each c in Range("W2:W2000")
	if c = x then
		Range("B" & c.row).resize(0,2).copy Sheets("M").Range("A" & laatsteregelBlad2)
	end if
next

Tot morgen heren.

Groet,
Ferenc

ps,
7 min. doe ik er over voor een reply.
Komt allemaal wel goed :)
Voordat je er over begint deze duurde weer iets langer :)
 
Laatst bewerkt:
Demeter zei:
Kan het niet laten, het grijpt me steeds dichter om mijn strot.

Voor de M-serie kom in de buurt van:
Code: 
For each c in Range("W2:W2000")
	if c = x then
		Range("B" & c.row).resize(0,2).copy Sheets("M").Range("A" & laatsteregelBlad2)
	end if
next

Tot morgen heren.

Groet,
Ferenc

ps,
7 min. doe ik er over voor een reply.
Komt allemaal wel goed :)
Voordat je er over begint deze duurde weer iets langer :)
Klik om te vergroten...

No prob Ferenc.

Maar een loop zoals je voorstelt moeten we wel zien te vermijden. (hier is mijn efficiëntie dada weer ;): het werkt maar het kan sneller, zeker voor veel rijen zoals hier)

Wigi
 
Hier dan het beloofde antwoord, al heb ik vandaag wel veel overuren geklopt :confused: :evil: damn

Anyway, hier zal je al veel mee opschieten, als het al niet helemaal opgelost is:

Code: 
Option Explicit

Sub Entiteiten()
Dim rng As Range, colM As Integer, i As Integer, sCateg As String, wshOutput As Worksheet, rngAF As Range

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With

colM = Range("A1", Cells(1, Columns.Count).End(xlToLeft)).Find(What:="M", LookIn:=xlFormulas, _
        LookAt:=xlWhole, MatchCase:=True).Column
Set rngAF = Range("A1", Cells(1, colM + 4))

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
If Not ActiveSheet.AutoFilterMode Then rngAF.AutoFilter

For i = 0 To 4
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    rngAF.AutoFilter Field:=colM + i, Criteria1:="x"
    sCateg = Cells(1, colM + i)
    
    On Error Resume Next
    Sheets(sCateg).Delete
    Set wshOutput = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    wshOutput.Name = sCateg
    
    Sheets("Blad1").Activate
    
    With ActiveSheet.AutoFilter.Range
            Set rng = .Offset(1).Resize(.Rows.Count - 1).Columns(colM + i).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With
    
    If Not rng Is Nothing Then
        rng.Offset(, -colM - i + 2).Copy wshOutput.Range("A1")
        rng.Offset(, -colM - i + 4).Copy wshOutput.Range("B1")
    End If
    Set rng = Nothing
Next
ActiveSheet.ShowAllData

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Code komt in een nieuwe Module. Gewoon uitvoeren met Alt-F8.

Telkens als je de code opnieuw uitvoert, worden de oorspronkelijk aangemaakte tabbladen wel gedeleted.

Slaapwel

Wigi
 
Wigi,

Heel knap zoals je dat in elkaar hebt gezet, alleen heb ik je volgens mij wel van een gedeelte van je nachtrust beroofd dat vind ik dus minder.

Voor mij hogere VBA school begrijp in grote lijnen wel hoe je het gebouwd hebt en met deze oplossing kom ik al heel ver.

Een punt van aandacht die ik waarschijnlijk niet goed heb uitgelegd en ik zie ook dat mijn voorbeeld daar verwarring over schept. In de templates kolommen "M" "A" "W" "K" "L " mag maar een "x" kruisje per entiteit staan en wel op de regel waar de naam van de betreffende entiteit staat. Herkenbaar aan de naam die in HOOFDLETTERS is weergegeven en uiteraard aan het ontbreken van een attribuutnaam.

Als in een van de template kolommen dan een "x" staat moet er vervolgens gekeken worden naar de kolom "v" binnen de betreffende unieke entiteitscode. Van alle "x" in de kolom "v" dient dan de bijbehorende entiteitscode (kolom B) en de attribuutcode (kolom D) gekopieerd te worden naar het nieuwe werkblad.
Met de oplossing die ik nu gekregen heb van Wigi kom ik al heel ver, je moest eens weten hoeveel uurtjes ik al aan het puzzelen geweest ben. En hier leer ik weer verschrikkelijk veel van.

Jullie moeten alleen niet je nachtrust gaan opofferen dan voel ik me teveel bezwaard.:)
 
Laatst bewerkt:
Is voor mij de eerste keer dat ik wat vraag

Was bijzonder tevreden met het antwoord van Wigi had echter nog een vraagje die ik ook vermeldt heb.
Daar ik geen reacties krijg denk ik wat fout gedaan te hebben op dit forum, misschien dat jullie me even op het goede spoor kunnen helpen

Jan
 
Je bericht stond bij mij in de wachtrij. Ik kijk er zeker naar, alleen kan ik nu nog niet zeggen wanneer.

Wigi
 
Wigi zei:
Je bericht stond bij mij in de wachtrij. Ik kijk er zeker naar, alleen kan ik nu nog niet zeggen wanneer.

Wigi
Klik om te vergroten...

Oke Wigi ik wacht geduldig af heb dus niets fout gedaan schijnbaar.

en niet te laat maken he

Groet,

Jan
 
jan07 zei:
Oke Wigi ik wacht geduldig af heb dus niets fout gedaan schijnbaar.

en niet te laat maken he

Groet,

Jan
Klik om te vergroten...


Inmiddels is het probleem op een aangepaste manier opgelost dus sluit ik deze vraag. Aan allen die er aan meegedacht hebben bedankt.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan