rij knippen en plakken via macro

[Wallo]

Dag iedereen,
Wie weet hier raad mee? Wat ik wil verkrijgen met een macro is dat ik via verticaal zoeken in een inventaris (bv zoeken op een nummer) de bijhorende rij knip en plak in een ander werkblad. Alvast bedankt!

 

[danny147]

Beste Wallo

Zie hier een gelijkaardig bestandje.
ipv Ja zet jij jouw nummer in en verander de kolom waar dit nummer in staat.

Anders plaats een voorbeeldbestandje hier en wij vullen het er wel in.

Groetjes Danny. :thumb:

 

[danny147]

Beste

Zie hier een aangepaste code.
Het gezochte cijfer (in dit geval = 15) staat in kolom A.

Sub Kopie()
    Application.ScreenUpdating = False
   Dim c As Range
   For Each c In [A1:A10000]
        If c = 15  Then
            c.Rows.EntireRow.Copy
            ["Blad2"!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
   For Each c In [A1:A10000]
        If c = 15 Then
            c.Rows.EntireRow.Delete
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Groetjes Danny. :thumb:

 

[Wallo]

Bedankt Danny voor de snelle reactie. Ik heb uw macro gekopieerd naar een vb maar als ik op de knop klik geeft hij foutmelding bij blad2, ik voeg dit vb bij.

 

[Joske2000]

["Blad2"!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

moet worden

[[COLOR="Red"]'[/COLOR]Blad2[COLOR="Red"]'[/COLOR]!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Joske

 

[Wallo]

Bedankt Joske het werkt, nu, deze makro werkt alleen als het getal 15 wordt ingevoerd in ik weet niet waar maar ik veronderstel ergens in kolom A, wat de bedoeling is dat je via altijd dezelfde cel een rij opzoekt in een inventaris met een nummer (dat niet altijd hetzelfde is)en dan deze bijhorende rij kopieerd naar blad2 wat deze macro doet.

 

[popipipo]

Verander het getal 15 in [B1]

Nu neemt hij niet 15 maar het getal wat je in B1 hebt staan.

 

[snb]

Of
als slechts 1 waarde in de kolom aan de voorwaarde voldoet

Sub Kopie()
   With sheets(1).columns(1).find(15,,xlvalue,xlWhole).entirerow
     .copy sheets("Blad2").cells(rows.count,1).end(xlup).offset(1).entirerow
     .delete
   End with
End Sub

en als dat er meer zijn

Sub test()
  On Error Resume Next
  Do
    With Sheets("Blad1").Columns(1).Find(15, , xlValue, xlWhole).EntireRow
       .Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
       .Delete
     End With
  Loop Until Err.Number > 0
End Sub

 

[Warme bakkertje]

Kleine aanpassing

Sub Kopie()
   With Sheets(1).Columns(1).Find(15, , xlValue[COLOR="Red"]s[/COLOR], xlWhole).EntireRow
     .Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow
     .Delete
   End With
End Sub

Sub test()
  On Error Resume Next
  Do
    With Sheets("Blad1").Columns(1).Find(15, , xlValue[COLOR="red"]s[/COLOR], xlWhole).EntireRow
       .Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
       .Delete
     End With
  Loop Until Err.Number > 0
End Sub

 

[danny147]

Beste Wallo

Als je wilt zoeken met de waarde van een cel, doe dan het volgende.
In dit geval moet de te zoeken waarde in cel G1 geplaatst worden.

Sub test()
  On Error Resume Next
  Do
    With Sheets("Blad1").Columns(1).Find([G1], , xlValues, xlWhole).EntireRow
       .Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
       .Delete
     End With
  Loop Until Err.Number > 0
End Sub

Groetjes Danny. :thumb:

 

[Wallo]

Iedereen hartelijk bedankt voor de massale reacties, de wijziging van popipipo heb ik gebruikt en dit werkt prima, ik plaats het bestand en de macro hierbij zodat jullie kunnen zien wat ik gebruikt heb. Nogmaals bedankt voor de reacties.

Sub rijknippen()
Application.ScreenUpdating = False
Dim c As Range
For Each c In [A1:A10000]
If c = [B1] Then
c.Rows.EntireRow.Copy
['Blad2'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next
For Each c In [A1:A10000]
If c = [B1] Then
c.Rows.EntireRow.Delete
End If
Next
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
:thumb:

 

[Warme bakkertje]

Wallo, het staat je natuurlijk vrij om te gebruiken wat je wil, maar als goede buur zou ik je toch adviseren om onderstaande te gebruiken om de eenvoudige reden dat je hiermee vermijd om tweemaal een lus te doorlopen van 10000 lijen

Sub test()
  On Error Resume Next
  Do
    With Sheets("Blad1").Columns(1).Find([B1], , xlValues, xlWhole).EntireRow
       .Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
       .Delete
     End With
  Loop Until Err.Number > 0
End Sub

 

[Wallo]

Bedankt Warme Bakkertje voor de toelichting, het werkt inderdaad veel sneller.:thumb::thumb::thumb:

 

[Wallo]

Dag Warme Bakkertje hier ben ik terug, graag had ik uw macro uitgebreid met deze,

Sheets("blad 2").Select
Rows("3:3").Select
Selection.Insert Shift:=xlDown

heb al vanalles geprobeerd maar het lukt me niet, weet jij hier raad mee? Alvast bedankt.
Groetjes Wallo