Kopieercode werkt alleen als kolom A is ingevuld

[EJProsman]

Ik ben bezig met een Excelsheet waarbij ik gebruik maak van code’s die ik vind op het web (ben nog niet heel goed met VBA). Meestal lukt het me wel deze code aan te passen aan mijn eisen maar deze keer lukte dat niet.

Op het web heb ik deze code gevonden om gegevens vanuit een tabblad naar een ander tabblad te kopiëren als ze voldoen aan een bepaalde eis. Het probleem is echter dat dit enkel werkt als Kolom A is ingevuld.

Kunnen jullie voor mij de volgende code aanpassen zodat het ook werkt als kolom A leeg is?:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
Sheets("Blad2").Range("A2:B" & UsedRange.Rows.Count).Clear
For Each cl In Range("B2:B" & UsedRange.Rows.Count)
If cl > 0 And cl.Offset(, 1) = "" Then
cl.EntireRow.Copy Sheets("Blad2").Range("A63536").End(xlUp).Offset(1)
End If
Next
End Sub

Ben hier al uren mee bezig geweest maar het wil me maar niet lukken..

Bij voorbaat dank,

EJProsman

Voorbeeldbestandje:
Bekijk bijlage Uit dienst.xlsm

 

[HSV]

De macro schrijft de cellen van Blad1 kolom B weg naar blad 2 als er iets in kolom B is ingevuld en kolom C leeg is.
Als er niets in kolom A staat dan wordt deze ook niet naar blad 2 geschreven.

Dus: kolom A heeft op zich niets van doen met de code tenzij B is ingevuld neemt het kolom A mee.
(cl.EntireRow.copy).

 

[EJProsman]

Hej, Bedankt voor je reactie. Ik krijg het echter nog steeds niet opgelost. Als je in het voorbeeld bestand op blad 2 krijgt zie je zoals het zou moeten zijn. Dit werkt alleen als bij kolom A gegevens ingevuld zijn. Wis kolom A in blad1 maar eens en zie wat er in blad2 gebeurt. Er staat dan nog maar 1 rij. Er zou gewoon hetzelfde moeten blijven staan als dat er eerst stond..
Ik heb geen flauw idee hoe dit komt..

Groetjes,
EJProsman

 

[HSV]

Lukt het hiermee.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim cl As Range
    With Sheets("Blad2")
     .Range("A2:B" & .UsedRange.Rows.Count).ClearContents
    End With
  For Each cl In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
     If cl > 0 And cl.Offset(, 1) = "" Then
   Sheets("Blad2").Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(, 2).Value _
   = cl.Offset(, -1).Resize(, 2).Value
  End If
 Next
End Sub

 

[EJProsman]

Hee HSV,

Bedankt voor je reactie. De code werkt perfect en slaat ook op als er niks in kolom A staat! Alleen ik hik alweer tegen het volgende probleem aan. Het is ook mogelijk dat er in de kolommen erachter nog wat staat wat ook gekopieerd moet worden. Ik snap vrij weinig van de code en ik weet niet wat ik aan moet passen om dit te regelen. Het gaat om de Kolommen C tot en met P.

Groetjes, EJProsman

 

[HSV]

Zet even je up to date bestandje hier neer, want in het voorbeeldbestandje staat wel iets in kolom C, maar die moet niet mee toch?

 

[EJProsman]

Bij deze:

Ik heb jou code er in geplakt en kolommen toegevoegd die ook gekopieerd moeten worden.

Als het mogelijk is, de kolommen die na de kolom P komen niet kopieren. Dit zijn er namelijk heel veel, en ik ben bang dat het anders langzaam wordt.

Bij voorbaat dank,

EJProsman

 

[HSV]

Volgens mij zoiets dus.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim cl As Range
    With Sheets("Blad2")
     .Range("A2:O" & .UsedRange.Rows.Count).ClearContents
 
  For Each cl In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        If cl > 0 And cl.Offset(, 1) = "" Then
        
      .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(, 2).Value _
   = cl.Offset(, -1).Resize(, 2).Value
      .Cells(.Rows.Count, 2).End(xlUp).Offset(, 1).Resize(, 13).Value _
   = cl.Offset(, 2).Resize(, 13).Value
   
     End If
    Next
  End With
End Sub

 

[EJProsman]

Het werkt, ik ga de code's eens goed bestuderen / uitproberen zodat ik dit ook onder de knie krijg!
Veel dank!

EJProsman