• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Copy rows if value in column B

Status
Niet open voor verdere reacties.
E

Esducsafe

Gebruiker
Lid geworden
2 sep 2009
Berichten
185
@Helpers
Ik wil nadat er gegevens zijn ingevuld in de kolommen B tot en H daarvan op het zelfde blad een kopie maken te beginnen in kolom M.
Met onderstaand script wordt nu kolom voor kolom een kopie gemaakt.
Niet erg handig.

Weet iemand of en hoe je “Range("B" & i).Copy” kunt aanpassen, zodat telkens een kopie wordt gemaakt van het hele gebied (B10: H).
Meerdere pogingen geprobeerd, maar het lukt mij niet iets wat werkt te vinden.
Alvast bedankt,
Esko

Bekijk bijlage Copy rows if value in column B.xls

Code: 
Sub Overzetten()

Dim lr As Long, i As Long
    With ActiveSheet    
    lr = .Range("B" & Rows.Count).End(xlUp).Row
    
    For i = 10 To lr  'neem over vanaf Rij 10    
    If .Range("B" & i).Value <> "" Then    
    .Range("B" & i).Copy Destination:=Sheets("Blad1").Range("M" & i)
    .Range("C" & i).Copy Destination:=Sheets("Blad1").Range("N" & i)       
         End If
        Next i
    End With
End Sub
 
Bv.
Code: 
sub hsv()
  sv = range("b10").currentregion.resize(,7)
  range("m10").resize(ubound(sv), 7) =sv
end sub
 
Harry,

Dat was snel en erg bedankt.
Direct getest en het werkt, super.

Misschien moet ik de volgende keer als ik iets niet kan vinden
maar sneller mijn vraag op "Helpmij" zetten.
In dit geval had het wel heel wat uurtjes kunnen schelen, dom van mij.
Esko
 
De oplossing was toch niet helemaal wat ik wilde.
Onderstaande oplossing werkt wel. :p
Esko

Code: 
Sub Sheets_Copy_Data()
Dim ws As Worksheet, lr As Long, r As Long

With Sheets("Blad1")
.Range("M9:R" & .Range("M9").End(xlDown).Row).ClearContents 'eerst leegmaken kopieer gebied

lr = Sheets("Blad1").Cells(Rows.Count, "M").End(xlUp).Row + 8 '+ 7
        For r = 8 To 15000
           If IsDate(Range("B" & r)) Then
               Range("B" & r & ":G" & r).Copy Sheets("Blad1").Range("M" & lr)
               lr = Sheets("Blad1").Cells(Rows.Count, "M").End(xlUp).Row + 1
           End If
        Next r
End With
End Sub
 
Wat heeft deze oplossing met het voorbeeldbestand te maken? Voor het verplaatsen van gegevens kan je veel beter het autofilter of geavanceerde filter gebruiken ipv alles regel voor regel te bekijken. Als je With en End With gebruikt doe het dan ook goed.

Code: 
Sub VenA()
  Dim cl As Range
  With Sheets("Blad1")
    [COLOR="#FF0000"][SIZE=6].[/SIZE][/COLOR]Range("M9:R" & [COLOR="#FF0000"][SIZE=6].[/SIZE][/COLOR]Cells(Rows.Count, 13).End(xlUp).Row).ClearContents
    For Each cl In [COLOR="#FF0000"][SIZE=6].[/SIZE][/COLOR]Range("B8:B" & [COLOR="#FF0000"][SIZE=6].[/SIZE][/COLOR]Cells(Rows.Count, 2).End(xlUp).Rows).SpecialCells(2, 1)
      If IsDate(cl) Then [COLOR="#FF0000"][SIZE=6].[/SIZE][/COLOR]Cells(Application.Max(8, [COLOR="#FF0000"][SIZE=6].[/SIZE][/COLOR]Cells(Rows.Count, 13).End(xlUp).Offset(1).Row), 13).Resize(, 6) = cl.Resize(, 6).Value
    Next cl
  End With
End Sub
 
Er staat een 's' teveel in je code @VenA.
 
Beste VenA.
Dank voor je reactie.
Je vraagt je af: "Wat heeft deze oplossing met het voorbeeldbestand te maken? "
Simpel (alles): De kopie van de data gebruik ik om deze, als een gebruiker
gegevens per ongeluk verwijderd, terug te kunnen zetten.
Je bijdrage heb ik getest en die werkt niet.
Mijn oplossing heb ik wel vooraf getest.
Esko


Bekijk bijlage Copy rows if value in column B X.xls
 
Laatst bewerkt:
De aanvullende opmerking van @HSV ook toegepast? 15.000 keer een lus doorlopen lijkt mij niet nodig. Waarom gebruik gebruik je geen kolomkoppen en een filter. Het laatste bestand geeft ook weer weinig inzicht in het doel van deze exercitie.
 
@VenA
Ok, je hebt gelijk 15000 rijen doorzoeken is niet slim.
Jouw code werkt nu en snel.
Bedankt.
Esko

Code: 
Sub VenA()
  Dim cl As Range
  With Sheets("Blad1")
    .Range("M8:R" & .Cells(Rows.Count, 13).End(xlUp).Row).ClearContents
    For Each cl In .Range("B8:B" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(2, 1)
      If IsDate(cl) Then .Cells(Application.Max(8, .Cells(Rows.Count, 13).End(xlUp).Offset(1).Row), 13).Resize(, 6) = cl.Resize(, 6).Value
    Next cl
  End With
End Sub
 
Elke cel heeft een datum, wat is het nut er van om daarop te controleren.
Ook wil je het terugzetten als er iets per ongeluk is verwijderd schrijf je.
Stel dat er geen datum is wordt die rij niet meegenomen in je kopie, wat wil je dan terugzetten?

De code past in dat opzicht best bij de uitleg (niet best).
 
Harry,
Ik zal morgen een voorbeeldbestandje uitwerken en plaatsen,
dan kun je zien wat mijn opzet is.
Misschien zijn ook hier verbeteringen mogelijk.
Wie weet.
Groet,
Esko
 
Is zoiets niet wat logischer?

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
  Application.EnableEvents = False
     If MsgBox("Wilt u geselecteerde gegevens verwijderen?" & vbCrLf & _
          "Klik op [Ja] als u dit zeker weet. " & vbCrLf & _
          "Klik op [Nee] indien u niets wilt verwijderen." & vbCrLf & _
          " ", vbExclamation + vbYesNo, " Verwijderen ") = vbNo Then
          Application.Undo
      Else
        Target.Resize(, 6).ClearContents
        Range("B8", Range("G65536").End(xlUp)).Sort [B8], 2 'sorteer opnieuw
    End If
  Application.EnableEvents = True
End If
End Sub
 
Beste VenA,
Dank voor je inbreng.:thumb:
Natuurlijk veel logischer.
Weer veel geleerd.
Hartstikke bedankt.
Groet,
Esko
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan