rng2.Select geeft foutmelding 1004

[trbogaert]

Hoi,

Ik ben net nieuw met macro's en dergelijke en probeer een macro op te zetten die, indien in een bepaalde cel de waarde '1' voorkomt, de naastliggende cel te kopiëren en in een ander tabblad te plakken. Alle geplakte waarden moeten direct onder elkaar komen zonder lege ruimtes. Voorbeeld:

1 - Waarde 1
0 - Waarde 2
1 - Waarde 3
1 - Waarde 4
0 - Waarde 5

geeft:

Waarde 1
Waarde 3
Waarde 4

Hiertoe heb ik de onderstaande macro geschreven/bij elkaar geraapt. Wanneer ik deze probeer te runnen komt er echter een foutmelding en wordt de regel met 'rng2.Select' gemarkeerd. In een simpele testmacro werkte deze functie echter wel. Weet iemand hoe ik dit probleem kan oplossen? Bedank!
~ Tom

Private Sub CommandButton1_Click()

Dim rng1 As Range
Dim rng2 As Range
 
Sheets("Printen").Activate
ActiveSheet.Range("A:A").Select
Selection.Delete
Sheets("Selecteren").Activate
Set rng2 = Range("A1")
 
ActiveSheet.Range("C4").Select
 
Do While IsEmpty(ActiveCell) = False
 
    If Selection.Value = 1 Then
 
        Set rng1 = ActiveCell
 
        ActiveCell.Offset(0, 1).Select
        Selection.Copy
 
        Sheets("Printen").Activate
        rng2.Select
 
        Selection.PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
        ActiveCell.Offset(1, 0).Select
        Set rng2 = ActiveCell
 
        Sheets("Selecteren").Activate
        rng1.Select
 
    End If
 
    ActiveCell.Offset(1, 0).Select
    
Loop
 
Application.CutCopyMode = False
   
  
    
End Sub

 

[Roncancio]

Persoonlijk zou ik autofilter gebruiken, zeker bij grote aantallen.

Sub overzetten()
Sheets("Selecteren").Range("A1").AutoFilter 1, 1
Sheets("Selecteren").Range("A1:B10").SpecialCells(xlCellTypeVisible).Copy Sheets("printen").Range("A1")
 
End Sub

Onderstaande is een stuk omslachtiger maar wel makkelijker te begrijpen.

Sub overzetten()
lRij = 1
lSRij = 1
While Sheets("Selecteren").Range("A" & lRij).Value <> ""
    If Sheets("Selecteren").Range("A" & lRij).Value = 1 Then
        Sheets("printen").Range("A" & lSRij).Value = Sheets("Selecteren").Range("A" & lRij).Value
        Sheets("printen").Range("B" & lSRij).Value = Sheets("Selecteren").Range("B" & lRij).Value
        lSRij = lSRij + 1
    End If
    lRij = lRij + 1
Wend
End Sub

Met vriendelijke groet,


Roncancio

 

[Warme bakkertje]

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Sheets("Printen").Columns(1).ClearContents
    With Sheets("Selecteren")
        For Each c In Range("C4:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
            If c.Value = 1 Then
                c.Offset(, 1).Copy
                Sheets("Printen").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, _
                        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Sheets("Printen").Range("A65536").End(xlUp).PasteSpecial Paste:=xlPasteFormats, _
                        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End If
        Next
    End With
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub