• 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.

bepaalde kolommen kopieren na voldaan voorwaarde

Status
Niet open voor verdere reacties.
M

maomanna

Gebruiker
Lid geworden
20 feb 2014
Berichten
234
Hallo allen,

ik gebruik deze macro
Code: 
Sub MoveColumns()
Dim wsO As Worksheet
Dim wsF As Worksheet
Dim i As Integer

Set wsO = Worksheets("Aanmeldingen 2017")
Set wsF = Worksheets("Lopend 2017")

Application.ScreenUpdating = False

myColumns = Array("Voornaam", "Tussenvoegsel", "Achternaam", "Supervisie formulier noodzakelijk?", "leidinggevende", "Datum aanmeldformulier retour")
With wsO.Range("A1:W1")
For i = 0 To UBound(myColumns)
On Error Resume Next
.Find(myColumns(i)).EntireColumn.Copy Destination:=wsF.Cells(1, i + 1)
Err.Clear
Next i
End With
Set wsO = Nothing
Set wsF = Nothing
Application.ScreenUpdating = True
End Sub

Dat mag pas uitgevoerd worden als in de kolom Datum aanmeldformulier retour, geen "X" of "x" is.

Waar moet ik de voorwaaden plaatsen?
Code: 
If Cells(n, "Q").Value = "X" Or Cells(n, "Q").Value = "x" Then
 
Zonder bestand zou ik er dit van maken:
Code: 
Sub MoveColumns()
Dim wsO As Worksheet
Dim wsF As Worksheet
Dim i As Integer

Set wsO = Worksheets("Aanmeldingen 2017")
Set wsF = Worksheets("Lopend 2017")

Application.ScreenUpdating = False

myColumns = Array("Voornaam", "Tussenvoegsel", "Achternaam", "Supervisie formulier noodzakelijk?", "leidinggevende", "Datum aanmeldformulier retour")
With wsO.Range("A1:W1")
For i = 0 To UBound(myColumns)
On Error Resume Next
[COLOR="#FF0000"]' natuurlijk moet je de locatie van Cells(.,.) nog bepalen!!
 If UCase(Cells(n, "Q")).Value <> "X" Then[/COLOR]
  .Find(myColumns(i)).EntireColumn.Copy Destination:=wsF.Cells(1, i + 1)
[COLOR="#FF0000"] End If[/COLOR]
Err.Clear
Next i
End With
Set wsO = Nothing
Set wsF = Nothing
Application.ScreenUpdating = True
End Sub
 
Laatst bewerkt:
Je schrijft de gegevens per kolom weg maar wil de controle doen op regelniveau, dat gaat niet lukken.
 
Ik heb in tabblad lopend niet alle kolommen nodig die in tabblad aanmeldingen staan.

De rij mag pas weg als de cel in de kolom formulier retour geen X meer is (een datum in dit geval)

is er een manier om dat zo te krijgen?
 
Ja maar dan pas straks,
moeder de vrouw je weet wel. :)
 
haha was meer een algemene vraag, maar geen enkel probleem!
Ben al blij dat je mij wilt helpen! Dank alvast!
 
Probeer het zo eens

Code: 
Sub VenA()
Application.EnableEvents = False
Dim j As Long
With Blad1
  For j = .Columns(9).SpecialCells(2).Count To 2 Step -1
    If LCase(.Cells(j, 9)) <> "x" Then
      Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 4), .Cells(j, 7), .Cells(j, 9))
      .Cells(j, 1).EntireRow.Delete
    End If
  Next j
End With
Application.EnableEvents = True
End Sub
 
Top! die werkt goed!

Edit:
nu komt er nog een vraag bij.
hij kopieert (en verwijderd) nu bepaalde rijen die aan de voorwaarden voldoen.

is het mogelijk om dan het blad waar het heen wordt gekopieerd, aan te vullen met X'jes?
een tabel maken gaat niet, vanwege gedeeld document.
 
Laatst bewerkt:
Waar moeten de X'jes komen en wat is het nut ervan? Jouw Change Events steken ook niet echt lekker in elkaar. Ik begrijp wel ongeveer wat het moet doen maar ook hier weer wat is het nut ervan? Je krijgt 1 grote kleurplaat;)
 
Code: 
Sub hsv()
Application.EnableEvents = False
Dim sn, sp, sq, j As Long, c00 As String, c01 As String
With Blad1
sn = .Columns(1).SpecialCells(2).Resize(, 9)
  For j = 2 To UBound(sn)
    If LCase(sn(j, 9)) <> "x" Then
      c00 = c00 & "_" & j
      sn(j, 9) = "x"
    Else
      c01 = c01 & "_" & j
    End If
  Next
sp = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4, 7, 9))
sq = Application.Index(sn, Application.Transpose(Split(Mid(c01, 2), "_")), Application.Transpose([row(1:9)]))
  Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp), 6) = sp
    .Columns(1).SpecialCells(2).Offset(1).Resize(, 9).ClearContents
    .Range("a2").Resize(UBound(sq), 9) = sq
End With
Application.EnableEvents = True
End Sub
 
VenA zei:
Waar moeten de X'jes komen en wat is het nut ervan? Jouw Change Events steken ook niet echt lekker in elkaar. Ik begrijp wel ongeveer wat het moet doen maar ook hier weer wat is het nut ervan? Je krijgt 1 grote kleurplaat;)
Klik om te vergroten...

Het doel van de kleurtjes is om snel inzichtelijk te krijgen wat er nog gedaan moet worden.
Leeg laten kan natuurlijk ook, dan moet de gekleurde voorwaarde daar op worden ingesteld.

HSV zei:
Code: 
Sub hsv()
Application.EnableEvents = False
Dim sn, sp, sq, j As Long, c00 As String, c01 As String
With Blad1
sn = .Columns(1).SpecialCells(2).Resize(, 9)
  For j = 2 To UBound(sn)
    If LCase(sn(j, 9)) <> "x" Then
      c00 = c00 & "_" & j
      sn(j, 9) = "x"
    Else
      c01 = c01 & "_" & j
    End If
  Next
sp = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4, 7, 9))
sq = Application.Index(sn, Application.Transpose(Split(Mid(c01, 2), "_")), Application.Transpose([row(1:9)]))
  Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp), 6) = sp
    .Columns(1).SpecialCells(2).Offset(1).Resize(, 9).ClearContents
    .Range("a2").Resize(UBound(sq), 9) = sq
End With
Application.EnableEvents = True
End Sub
Klik om te vergroten...

Deze code lijkt zichzelf te herhalen, namelijk dat hij meerdere (6) regels aanmaakt bij het kopieren.
 
Laatst bewerkt:
Waar zit een herhaling?
 

Bijlagen

Laatst bewerkt:
zodra in tabblad Aanmeldingen 2017 een datum staat in Datum aanmelding retour, kopieert ie die regel 6x naar het tabblad Lopend 2017
 
De code van HSV werkt hier prima in jouw voorbeeld bestand.

Als je overal een "x" wil hebben dat kan je bv dit gebruiken
Code: 
Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 20) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 4), .Cells(j, 7), .Cells(j, 9), "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x")
 
Dank @VenA,

Ik begrijp ook niet waarom het 6 keer geplaatst wordt bij de Ts.
Het kan ook niet, de lus loopt de rijen een voor een af en geeft geen dubbele rijnummers. ;)
Van mijn part staan er nog honderd datums in kolom I.

Voor de x-en.
Code: 
Sub hsv()
Application.EnableEvents = False
Dim sn, sp, sq, i As Long, c00 As String, c01 As String
With Blad1
sn = .Columns(1).SpecialCells(2).Resize(, 20)
  For i = 2 To UBound(sn)
    If LCase(sn(i, 9)) <> "x" Then
      c00 = c00 & "_" & i
        sn(i, 9) = "x"
    Else
      c01 = c01 & "_" & i
    End If
  Next i
If c00 <> "" Then
  sp = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4, 7, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9))
  sq = Application.Index(sn, Application.Transpose(Split(Mid(c01, 2), "_")), Application.Transpose([row(1:9)]))
  Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sp), 20) = sp
    .Columns(1).SpecialCells(2).Offset(1).Resize(, 9).ClearContents
    .Range("a2").Resize(UBound(sq), 9) = sq
 End If
End With
Application.EnableEvents = True
End Sub
 
@HSV,

Code: 
sp = Application.Index(sn, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4, 7, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9))
sq = Application.Index(sn, Application.Transpose(Split(Mid(c01, 2), "_")), Application.Transpose([row(1:9)]))

Koste wat moeite om het te begrijpen, is ook niet te 'debuggen', maar wel een mooie aanvulling op mijn kennis van het vullen van een Array.:thumb:
 
VenA zei:
De code van HSV werkt hier prima in jouw voorbeeld bestand.

Als je overal een "x" wil hebben dat kan je bv dit gebruiken
Code: 
Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 20) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 4), .Cells(j, 7), .Cells(j, 9), "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x")
Klik om te vergroten...

HSV zei:
Dank @VenA,

Ik begrijp ook niet waarom het 6 keer geplaatst wordt bij de Ts.
Het kan ook niet, de lus loopt de rijen een voor een af en geeft geen dubbele rijnummers. ;)
Van mijn part staan er nog honderd datums in kolom I.
Klik om te vergroten...

Ik heb de macro 2x uitgevoerd -> datum ingevuld bij aanmeldformulier retour, Macro uitgevoerd, bij een ander een datum ingevuld, macro uitgevoerd.
Bij de tweede keer krijg ik meerdere regels van de persoon. Zie voorbeeldbestand hieronder. Geen idee hoe dat komt.

Bekijk bijlage lopend 2017.xlsb
 
Als je maar 1 datum invult dan wordt sp een 1-dimensionale array met een ubound van 20 en tja dan krijg je 20 rijen. Dit soort dingen zijn eenvoudig te zien als je even met <F8> door de code loopt.

Code: 
Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize([COLOR="#FF0000"]UBound(Split(c00, "_")), 20[/COLOR]) = sp
 
VenA zei:
De code van HSV werkt hier prima in jouw voorbeeld bestand.

Als je overal een "x" wil hebben dat kan je bv dit gebruiken
Code: 
Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 20) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 4), .Cells(j, 7), .Cells(j, 9), "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x", "x")
Klik om te vergroten...

ik ben verder gegaan met de code van VenA, ondanks dat erg bedankt voor je input HSV!

Is het mogelijk om ipv een "x" ook een formule te plaatsen?

Dit werkt niet.
Code: 
    Blad24.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 16) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 4), , .Cells(j, 7), .Cells(j, 9), "x", "x", "x", "x", "x", "x", "x", "x", .Cells(j, 10), "", "", "", ActiveCell.Offset(j, 20).Formula = "=IF(OR(AND(ActiveCell.Offset(j, -16)=""Ja"";ActiveCell.Offset(j, -15)=""Ja"";ActiveCell.Offset(j, 1)=8);AND(ActiveCell.Offset(j, -16)=""Nee"";ActiveCell.Offset(j, -15)="";ActiveCell.Offset(j, 1)=8));""compleet"";""incompleet"")")


Edit:
In het excelbestand gaat de bovenstaande code verder prima (op de formule na)

Nu wil ik ook dat hij regels toevoegd aan een 3e blad, maar daar mogen geen dubbelingen inzitten.

dus als Piet al is gekopieerd (komt dus voor op 2 bladen), dat hij bij een nieuwe toevoeging onder aan sluit.

nu had ik iets als
Code: 
Dim i, LastRow

LastRow = Sheets("Lopend 2017").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Supervisie").Range("A2:R100").ClearContents
For i = 2 To LastRow
If Sheets("Lopend 2017").Cells(i, "D").Value = "Ja" Or Sheets("Lopend 2017").Cells(i, "D").Value = "ja" Then
Sheets("Lopend").Cells(i, "A").Row.Copy Destination:=Sheets("Supervisie").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i

maar dan ben ik ook de aanpassingen bij de mensen die al op het blad staan, kwijt.
Een weigering en msgbox is prima.

Jullie een idee?

Laatste is opgelost door een controle kolom, met VBA:
Code: 
If LCase(.Cells(j, 4)) = "Ja" Or LCase(.Cells(j, 4)) = "ja" And LCase(.Cells(j, 22)) <> 1 Then
        Blad2.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 9) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 4), .Cells(j, 6), .Cells(j, 16), "x", "x", "x")
        Blad24.Cells(j, 22).Value = 1
    End If

Alleen de formule nog.
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan