Regel kopieren op waarde van

[HWV]

Sub Wegschrijven()
Dim cl As Range

  For Each cl In Sheets("blad1").Range("L2:L30000")
   
    If cl > 0 Then cl.Offset(, -11).Resize(, 1).Copy Sheets("blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
   
    Next
    
End Sub

Met deze code kijk hij in blad1 of in kolom L een cel een hogere waarde heeft als 0.
Als dit zo is dan kopieer hij de cel van kolom A naar Blad 2.

nu wil ik de gehele regel kopieeren naar blad 2 als de celwaarde in kolom L hoger is als 0.

Hoe kan ik deze code aanpassen

Al vast bedankt voor de genomen moeite.

groet HWV

 

[danny147]

Beste HWV

Neem de volgende code:

Sub Wegschrijven()

    Application.ScreenUpdating = False

   Dim cl As Range
   For Each cl In Sheets("blad1").Range("L2:L30000")
        If cL = > 0 Then
            cl.Rows.EntireRow.Copy
            ['Blad2'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Groetjes Danny. :thumb:

 

[snb]

Hoger dan:

Sub Wegschrijven()
  For Each cl In Sheets("blad1").Range("L2:L30000")
    If cl > 0 Then Sheets("blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1).entirerow = cl.entirerow
  Next
End Sub

of

Sub Wegschrijven2()
  With [Blad1!L2:L30000]
    .autofilter 1, ">0"
    .offset(1).specialcells(xlcelltypevisible).copy  Sheets("blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
  End With
End Sub

 

[HWV]

Werkt nog niet helemaal

Beste,

Allereerst bedankt voor de reactie op mijn topic.

De code van danny147 doet goed zijn werk maar duurt erg lang.
De code van SNB daarintegen doet het helaas niet altijd, wat vreemd is.
Maar dan maak hij een copy van enkel kolom L , maar zou graag de hele rij willen hebben.
ik heb in het voorbeeld bestand alle code`s gezet om te laten zien hoe iets werkt en niet werkt.

Ik hoop toch dat we tot een juiste oplossing kunnen komen.Bj voorbaat la mijn dank.

groet HWV

 

[snb]

Sub Wegschrijven()
  For Each cl In Sheets("blad1").Range("L2:L30000")
    If cl > 0 Then Sheets("blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1).entirerow = cl.entirerow.[COLOR="Blue"]value[/COLOR]  
  Next
End Sub

 

[HWV]

Gelukt

Dank u wel.

Het is gelukt, bedankt voor het meedenken.

Groet HWV