Dat kopiëren op basis van cell inhoud

[TomH90]

Beste,

Ik heb 3 tabbladen namelijk:
- Overview
- Sheet2
- Sheet3

Op tabblad Overview staat een knop die de macro triggert

Op Sheet2 staan regels die gekopieerd moeten worden op het moment dat in kolom G een 1 staat. Deze regels mogen gekopieerd worden in de eerste lege cel van kolom B op Sheet3.

Een mooie nice to have zou zijn alleen tabblad Overview zichtbaar tijdens het kopieren en plakken

Tot nu toe heb ik

Sub Test()

Sheets("Sheet2").Select
For Each Cell In Sheets("Sheet2").Range("G:G")
    If Cell.Value = "1" Then
        matchRow = Cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy
        
        Sheets("Sheet3").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Sheet2").Select
    End If
Next

End Sub

wie kan mij hiermee helpen?

 

[edmoor]

Probeer deze eens:

Sub Test()
    Application.ScreenUpdating = False
    For Each Cel In Sheets("Sheet2").Range("G:G")
        If Cel.Value = "1" Then
            Sheets("Sheet2").Rows(Cel.Row).Copy Destination:=Sheets("Sheet3").Rows(Cel.Row)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Tip:
Gebruik geen correct Engelse woorden als naam van een variabele of object.
Ikk heb dus niet Cell gebruikt maar Cel.

 

[VenA]

Lijkt dit er meer op?

Sub Test()
For Each cl In Sheets("Sheet2").Columns(7).SpecialCells(2)
  If cl.Value = "1" Then cl.EntireRow.Copy Sheets("Sheet3").Cells(cl.Row, 1)
Next cl
End Sub

Edit. andere reactie niet gezien.

 

[TomH90]

Probeer deze eens:

Sub Test()
    Application.ScreenUpdating = False
    For Each Cel In Sheets("Sheet2").Range("G:G")
        If Cel.Value = "1" Then
            Sheets("Sheet2").Rows(Cel.Row).Copy Destination:=Sheets("Sheet3").Rows(Cel.Row)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Tip:
Gebruik geen correct Engelse woorden als naam van een variabele of object.
Ikk heb dus niet Cell gebruikt maar Cel.

Dit werkt al heel veel beter ja. enige nu nog is dat de regel nu in de eerste lege cel gekopieerd moet worden

 

[VenA]

Volgens mij kan je beter het autofilter gebruiken maar ik weet niet hoe jouw bestandje in elkaar steekt.

Sub Test()
Application.ScreenUpdating = False
For Each cl In Sheets("Sheet2").Columns(7).SpecialCells(2)
  If cl.Value = "1" Then cl.EntireRow.Copy Sheets("Sheet3").Cells(Rows.Count, 7).End(xlUp).Offset(1, -6)
Next cl
End Sub

 

[edmoor]

Lijkt dit er meer op?

Sub Test()
For Each cl In Sheets("Sheet2").Columns(7).SpecialCells(2)
  If cl.Value = "1" Then cl.EntireRow.Copy Sheets("Sheet3").Cells(cl.Row, 1)
Next cl
End Sub

Edit. andere reactie niet gezien.

Maar jouw voorbeeld is netter

 

[VenA]

Maar jouw voorbeeld is netter

Mooie aanvulling op elkaar toch