• 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 kopieren van ander tablad met als en op volgende regel

Status
Niet open voor verdere reacties.
K

Krist

Gebruiker
Lid geworden
18 nov 2002
Berichten
349
Hallo,

Ik kom hier niet uit...
Ik heb een werkblad met 2 tabbladen. Uit het eerste tabblad wil ik gegevens kopiëren naar het tweede, als aan 2 voorwaarden voldaan is. De kolom 'Controle' moet "Okee" zijn, en in de kolom 'Betaald' moet een "Ja" staan. Ik heb onderstaande gevonden, maar dat is maar voor 1 voorwaarde. Heb het bestandje in bijlage gestopt...

Alvast dank!
krist



Sub CommandButton1_Click()

Dim OutputRegel As Long
Dim x As Long
Dim LC As Integer
Dim y As Integer

OutputRegel = 19
For x = 3 To 12
For y = 4 To 100
If Cells(x, y) = "FOUT" Then
Worksheets("Blad2").Cells(OutputRegel, 2) = Worksheets("Blad2").Cells(x, 2)
Worksheets("Blad2").Cells(OutputRegel, 3) = Worksheets("Blad2").Cells(x, 3)
Worksheets("Blad2").Cells(OutputRegel, 4) = Worksheets("Blad2").Cells(x, 4)
Worksheets("Blad2").Cells(OutputRegel, 5) = Worksheets("Blad2").Cells(2, y)
Worksheets("Blad2").Cells(OutputRegel, 6) = Worksheets("Blad2").Cells(x, y + 1)
OutputRegel = OutputRegel + 1
End If
Next y
Next x

End Sub
 

Bijlagen

Krist,

je code en het bestand passen niet bij elkaar. Graag verder uitleggen wat de bedoeling is....

NB: een tweede voorwaarde toevoegen zou wellicht zo kunnen:
Code: 
If Cells(x, y) = "FOUT" and Cells(x,y+1) = "Okee"Then
 
Ah, okee... Zover gaat mijn kennis dus :)

In bijlage zat het werkblad met 2 tabbladen. Als bij het tabblad 'aanvragen' kolom F een "Okee" staat én kolom een "Ja", dan zouden volgende gegevens op de volgende lege rij in tabblad 'Effectief Gestart' moeten komen: 'Datum aanvraag', 'Naam' en 'Geb.Datum'...

Dank
 
en wat moet er dan gebeuren met de gegevens in tabblad "Aanvragen" gebeuren?
 
Deze zouden gewoon moeten blijven staan... Ze worden dan verder aangevuld tijdens het jaar... En zouden dan door de macro telkens naar 'Effectief Gestart' moeten gekopieerd. De eerdere gegevens op 'Effectief Gestart' mogen dan overschreven worden...
 
Als dus eenmaal de gegevens van regel 2 op blad Aanvragen naar blad Effectief Gestart, zijn gekopieerd moeten ze gewoon blijven staan?
Waarom voeg je dan niet op tabblad Aanvragen de gegevens aan?
 
Dat zou ook kunnen.
Maar ik wel op 'effectief Gestart' een overzicht van diegene die effectief gestart zijn.
Het is wel zo dat in het werkelijke document nog meerdere kolommen staan (op beide tabbladen).
Volgens de voorspelling zouden er meer dan 200 rijen kunnen zijn op het eerste tabblad.
Het lijkt me overzichtelijker als ik dan een extra tabblad heb met een overzicht. Vandaar...
 
Klopt... Dat heb ik in het begin gedaan. Maar zoals aangegeven, als ik alle gegevens van de 2 tabbladen op 1 zet, wordt het onoverzichtelijk. Ik heb nu een minimaal voorbeeldbestand mee gestuurd.
Er komen nog adresgegevens, rrn, contactgegevens, ... bij. Voor diegene die de gegevens van het tweede tabblad moeten zien, wordt het dan teveel om een overzicht te hebben. En omgekeerd ook...
 
Plaats dan een relevant voorbeeld bestand. Ik zie weinig relatie van wat je nu van het ene naar het andere blad wil. Al eens gekeken naar een draaitabel? ± 200 rijen is nu ook weer niet zo heel erg spannend.
 
Hallo,

Ben tot hier geraakt... Vooraleer hij kopieert moet nog aan de tweede voorwaarde voldoen, nl Kolom "O" moet 'Ja' zijn... Ik probeer
morgen eens het idee IF AND IF THEN..

gr
Krist

Sub Kopieer()
Dim Rij, SR As Integer
Rij = 2
SR = 2
While Worksheets(1).Cells(Rij, "N") <> ""
If Worksheets(1).Cells(Rij, "N") = "Okee" Then
Worksheets(2).Cells(SR, "C") = Worksheets(1).Cells(Rij, "A")
Worksheets(2).Cells(SR, "G") = Worksheets(1).Cells(Rij, "E")
Worksheets(2).Cells(SR, "I") = Worksheets(1).Cells(Rij, "H")
SR = SR + 1
End If
Rij = Rij + 1
Wend
End Sub
 

Bijlagen

probeer deze eens

Code: 
If Worksheets(1).Cells(Rij, "N") = "Okee" [COLOR="#FF0000"]AND Worksheets(1).Cells(Rij, "O") = "Ja"[/COLOR] Then
 
Wat het moet worden begrijp ik niet maar zo gaat het wat sneller.

Code: 
Sub VenA()
  Dim j As Long, t As Long, ar, ar2
  ar = Sheets("Aanvragen").Cells(1).CurrentRegion
  t = 2
  With Sheets("Effectief Gestart").Cells(1).CurrentRegion
    ar2 = .Value
    For j = 2 To UBound(ar)
      If LCase(ar(j, 14) & ar(j, 15)) = "okeeja" Then
        ar2(t, 3) = ar(j, 1)
        ar2(t, 4) = ar(j, 2)
        ar2(t, 7) = ar(j, 5)
        ar2(t, 9) = ar(j, 8)
        t = t + 1
      End If
    Next j
    .Value = ar2
  End With
End Sub

Nb. Gebruik codetags voor de leesbaarheid.
 
Goedemorgen,

Gisteren beide oplossingen uitgeprobeerd! Beide werken prima... Dankjewel!
Ik was aan het denken dat het mss, op termijn, veiliger zou zijn om er 2 documenten van te maken... Hoe verwijs ik dan naar een andere werkmap die in dezelfde bestandsmap staat.
Heb dit geprobeerd, wat niet lukt...

Sub VenA()
Dim j As Long, t As Long, ar, ar2
ar = Sheets("Aanvragen").Cells(1).CurrentRegion
t = 6
With Sheets("'[Effectief Gestart.xlsx]Blad1'!").Cells(1).CurrentRegion
ar2 = .Value
For j = 2 To UBound(ar)
If LCase(ar(j, 14) & ar(j, 15)) = "okeeja" Then
ar2(t, 3) = ar(j, 1)
ar2(t, 4) = ar(j, 2)
ar2(t, 7) = ar(j, 5)
ar2(t, 9) = ar(j, 8)
t = t + 1
End If
Next j
.Value = ar2
End With
End Sub
 
Nb. Gebruik codetags voor de leesbaarheid.
Klik om te vergroten...
blijkbaar gemist?

Zo maakt het niet uit of het bestand al geopend is.
Code: 
With GetObject(ThisWorkbook.Path & "\Effectief Gestart.xlsx").Sheets("Blad1").Cells(1).CurrentRegion
 
Dag VenA,

Dank voor de verbetering! Ik probeer het straks uit... Ik neem aan dat het zal werken :)
Ik zet deze dan ook als opgelost. Blij dat dit forum bestaat...

grtz
 
Hallo,

Toch nog een vraagje...
Ik heb wat opmaak gemaakt boven de data...
Ik wil de macro laten starten met zoeken op rij 8 tot einde en schrijven vanaf rij 6, maar dit lukt niet.
Na wat uitproberen, denk ik, omdat er een aantal lege rijen staan tussen 1 en 8.
Is dat op te lossen?

Alvast dank
Krist



Sub VenA()
Dim j As Long, t As Long, ar, ar2
ar = Sheets("Aanvragen").Cells(1).CurrentRegion
t = 6
With GetObject(ThisWorkbook.Path & "\Effectief Gestart.xlsx").Sheets("Blad1").Cells(1).CurrentRegion
ar2 = .Value
For j = 8 To UBound(ar)
If LCase(ar(j, 14) & ar(j, 15)) = "okeeja" Then
ar2(t, 3) = ar(j, 1)
ar2(t, 4) = ar(j, 2)
ar2(t, 7) = ar(j, 5)
ar2(t, 9) = ar(j, 8)
t = t + 1
End If
Next j
.Value = ar2
End With
End Sub
 
Wat is er zo moeilijk aan om de code even tussen codetags te plaatsen?

Welke cel denk je dat Cells(1) is?
 
Sorry voor de tags, heb het nu geprobeerd, hoop dat het lukt...
Ik weet dat cells(1) de eerste cel is op tabblad 'aanvragen' :)
Onderstaande werkt! Had niet door dat je vanuit een specifieke cel moet vertrekken. Ik dacht dat je een rij kon aanduiden... Je hint heeft mij gered!

Dankjewel!

Code: 
Sub VenA()
  Dim j As Long, t As Long, ar, ar2
  ar = Sheets("Aanvragen").Cells(8,1).CurrentRegion
  t = 6
  With GetObject(ThisWorkbook.Path & "\Effectief Gestart.xlsx").Sheets("Blad1").Cells(1).CurrentRegion
    ar2 = .Value
    For j = 1 To UBound(ar)
      If LCase(ar(j, 14) & ar(j, 15)) = "okeeja" Then
        ar2(t, 3) = ar(j, 1)
        ar2(t, 4) = ar(j, 2)
        ar2(t, 7) = ar(j, 5)
        ar2(t, 9) = ar(j, 8)
        t = t + 1
      End If
    Next j
    .Value = ar2
  End With
End Sub[\code]
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan