Macro werkt niet 100%

[rg027]

Beste,

Ik heb volgende macro. Deze zoekt bepaalde waarden in een groot bereik( deze kan meer dan rijen bevatten). Deze macro werkt ware het niet dat ik hem toch een aantal keren moet doen draaien om alle gevraagde gegevens te kunnen wegschrijven.Weet iemand hoe ik deze kan doen draaien zodat ie in 1 klik alle gevraagde gegevens wegschrijft?

Alvast dank.

Sub test()
Dim c As Range, i As Single

For Each c In Range("Code")
If c <> "" Then
If c = "1" Then
Range(c.Offset(0, -1), c.Offset(0, -8)).Copy
Sheets("Blad 2").Select
i = 1
Do Until i = 0
If Range("a7") <> "" Then
If Range("a7").Offset(i, 0) <> "" Then
i = i + 1
Else
Range("a7").Offset(i, 0).Select
ActiveSheet.Paste
i = 0
End If
Else
Range("a7").Select
ActiveSheet.Paste
i = 0
End If
Loop
c.EntireRow.Delete
End If
End If
Next c
Application.CutCopyMode = False
end sub

 

[Wigi]

Zet eerst eens code-tags aub. Laat wel de apostrof weg voor "code" (2 keer).

 

[rg027]

Sorry even niet aan gedacht.

Ik heb ondertussen verder blijven oefenen met de code en plots werkt die wel. vraag me af wat er mis is gegaan. Is alvast opgelost.

 

[Wigi]

Zet toch nog maar de code tags.

Trouwens, wat wil je in dit stuk doen?

For Each c In Range("Code")
If c <> "" Then
If c = "1" Then
Range(c.Offset(0, -1), c.Offset(0, -8)).Copy
Sheets("Blad 2").Select
i = 1
Do Until i = 0
If Range("a7") <> "" Then
If Range("a7").Offset(i, 0) <> "" Then
i = i + 1
Else
Range("a7").Offset(i, 0).Select
ActiveSheet.Paste
i = 0
End If
Else
Range("a7").Select
ActiveSheet.Paste
i = 0
End If
Loop

Dit kan veel simpeler als ik goed begrijp wat je wilt doen.

Wigi

 

[rg027]

Goed deze dus even plaatsen

Sub test()
Dim c As Range, i As Single

For Each c In Range("Code")
If c <> "" Then
If c = "1" Then
Range(c.Offset(0, -1), c.Offset(0, -8)).Copy
Sheets("Blad 2").Select
i = 1
Do Until i = 0
If Range("a7") <> "" Then
If Range("a7").Offset(i, 0) <> "" Then
i = i + 1
Else
Range("a7").Offset(i, 0).Select
ActiveSheet.Paste
i = 0
End If
Else
Range("a7").Select
ActiveSheet.Paste
i = 0
End If
Loop
c.EntireRow.Delete
End If
End If
Next c
Application.CutCopyMode = False
end sub

De bedoeling is dat er in het bereik "code" wordt gezocht naar de waarde 1 in dit geval en dat de rij waar deze waarde zich in bevind naar de eerst volgende lege rij van blad 2 schrijft te beginnen met cel A7. Als ie korter kan dan graag hoor. Deze macro is een onderdeel van een map met een 20-tal werkbladen waar naartoe moet geschreven worden vanuit een gegevens(order)werkblad.

Hopelijk ben ik wat duidelijk met men uitleg
Alvast dank voor de moeite en de tijd die je neemt om me te helpen Wigi.

 

[Wigi]

Zie Copy filtered rows en filter het juiste bereik op een 1. Kopieer dan die gevonden cellen.

Je code tags zijn goed nu. Probeer ook je code te laten inspringen, dat zorgt voor orde in je VBA code.

 

[rg027]

Wigi,

ik denk met een filter werken niet zo evidnt is daar ik met 1 druk op de knop alle gegevens wil wegschrijven. In de code die ik geschreven heb wordt naar het cijfer 1 gezocht, doch er zijn een tiental cijfers waarnaar moet worden gezocht en voor elk cijfer is er een bijhorend blad. Met de filter zou ik dan wel x aantal keer de filter moeten toepassen terwijl met de code , maar dan aangepast aan het cijfer, alles direct wordt weggeschreven. Of heb ik het verkeerd voor met die filter?

 

[Wigi]

Je hebt het verkeerd voor . De filter is vele malen sneller dan een lus doorheen de cellen.

Lussen kunnen wel efficiënt zijn, maar dan voor andere doeleinden. En jouw probleem geeft mij direct de aanleiding om een efficiënt gebruik van lussen aan te tonen: maak een lus doorheen de waarden die je moet zoeken (1, ...) en per waarde doe je dan een Autofilter en kopieer je de cellen. Je kan instellen waarop je wilt filteren. Beter dan dit kan je niet doen.

Wigi

 

[Wigi]

Ook het zoeken naar de juiste rij kan beter:

iets in de stijl van:

Dim rij As Long
rij = WorksheetFunction.Max(7, Sheets("Blad 2").Range("A" & Rows.Count).End(xlUp).Row + 1)

ongeteste code

Wigi

 

[rg027]

Inderdaad Wigi,

Met de filter gaat het een stuk sneller.

Hartelijke dank voor de geboden hulp

 

[Wigi]

Graag gedaan.

Proficiat dat je die code goed hebt gekregen, want dat is niet bij de simpelste code die er is. :thumb:

Wigi