VBA code wijzigen

[ROSO]

Wie kan mij met deze code helpen (excel 2003). Het werkt goed maar nu plaats ie alles vanaf cel A2 en ik wil dat ik plaats van af ce B2 (Range "A" moet leeg blijven voor ander data".

Alvast bedankt.

Private Sub CommandButton7_Click()
Dim c As Range
    
    Dim firstAddress As String
    
    Application.ScreenUpdating = False
    Set c = Sheets("Looplijst").Columns(15).Find("BlBR", LookIn:=xlValues, lookat:=xlWhole)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
           c.EntireRow.Copy Sheets("BlBR").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

            Set c = Sheets("Looplijst").Columns(15).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
    Application.ScreenUpdating = True
End Sub

 

[Wigi]

In de code staat maar op 1 plaats A, die ene keer moet je dat veranderen in een B en klaar ben je.

 

[ROSO]

Dat heb ik geprobeerd maar dan krijg ik een error code 1004 "Door de Toepassing of door Object gedefinieerde fout.

 

[Wigi]

Omdat je middels

c.EntireRow.Copy

een hele rij kopieert... die kan je niet plakken vanaf kolom B maar enkel vanaf kolom A.

 

[ROSO]

Hoe kan ik dit oplossen WiGi ????? Bedankt dat je zo snel reageert.

 

[Hoornvan]

ROSO,

Kun je niet een bereik ingeven wat gekopieerd moet worden?
b.v.b

[Blad1!A14:P14].Copy [Blad2!B14]

Dan lukt het wel denk ik.

 

[ROSO]

Hallo WiGi,

Nee dat gaat helaas niet, deze code haar gevens uit een ander blad dat ca. 6000 rec in heeft staan op verschillende plaatsen.

 

[Hoornvan]

ROSO,

Dan hou het op denk ik.
Je kunt geen volle regel kopieren en er dan 1 cel afhalen.

Dat bedoelde ik als het regel bereik 1 cel korter is dan denk ik dat het wel lukt.

Je weet het maar nooit, er zijn handige VBA ers die er misschien een foefje voor weten.

 

[ROSO]

We zullen zien WiGI, bedankt voor je moeite

 

[Hoornvan]

ROSO,

Dit bedoel ik cells(1, 100) als bereik, zou dit ook niet werken?

c.EntireRow.Cells(1, 100).Copy Sheets("BlBR").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)

 

[ROSO]

Helaas Hoornvan, dan kopieert ie niet. Maar geeft ook geen error melding.

 

[Wigi]

c.EntireRow.[B]Resize(,100)[/B].Cells(1, 100).Copy Sheets("BlBR").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)

 

[ROSO]

Helaas ook niet neemt niets meer en ook geen err code,

 

[snb]

Kopieer geen code die je niet begrijpt en a fortiori: gebruik geen code die je niet snapt en onnodig omslachtig is.

Private Sub CommandButton7_Click()
  With Sheets("Looplijst").usedrange
    .autofilter 15, "BlBR"
    .offset(1).specialcells(xlcelltypevisible).copy Sheets("BlBR").cells(Rows.Count,2).End(xlUp).Offset(1)
    .autofilter
  End with
End Sub

 

[ROSO]

BEDANKT SnB,

Code werkt zoals ik het wil. :thumb:

Een ieder die mee gedacht heeft ook bedankt:thumb: