VBA Kopieert enkel de rijden

[Verwijderd]

Hallo

Ik zit wat in de knoop et mijn VBA code, mijn VBA code kopieert enkel de volledige rijden die bvb het woord Nintendo bevatten. Maar wanneer men een nieuwe rij toevoegt aan het bestand met dezelfde keyword en de Marco terug laat draaien, dan zal hij alles terug kopiëren en plakken onder de bestaande cellen die de macro hiervoor gekopieerd heeft. (Alles staat dus gedupliceerd).

Kan men in VBa het document laten scannen op het bestaande keyword, nieuwe gegevens toevoegen aan het overzicht (op een ander worksheet) en de bestaande (die al in het andere worksheet staat) laten update indien ik op deze rij een wijziging heb doorgevoerd ?

Hier kan je de code terugvinden:

Sub NINTENDOOOO()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("PDC").UsedRange.Rows.Count 'bron waar hij de gegevens moet gaan zoeken
J = Worksheets("Sheet2").UsedRange.Rows.Count 'hier zal hij deze gegevens moeten naar toe brengen
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("PDC").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "NINTENDO " Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub


Spijtig genoeg kan ik het document niet toevoegen, want hier staan bedrijfsgegevens in die niet gepubliceerd morgen worden

[Verwijderd]

Hoi Detree,

Je geeft aan dat je steeds een geupdate sheet wil hebben, echter je code controleert of er al regels gebruikt zijn in je doelsheet.
Dit doet ie doormiddel van de controle op J (J = Worksheets("Sheet2").UsedRange.Rows.Count)

maar volgens mij wil je dat hij gewoon altijd op rij 1 begint? dus J zal altijd 0 moeten zijn.

dus de hele controle is niet nodig, en kan dus geschrapt worden. ook de if statement hierna j=1 gaat dan nergens om.

[Verwijderd]

bedant voor jouw antwoord, maar wat moet er dan juist weg van de hele controle.

Je moet ook weten als ik in mijn sheet 1 een rij toevoeg met het woord nintedo dan moet deze rij ook toegevoegd worden in mijn sheet 2

Mercikes

[Verwijderd]

Dit:
J = Worksheets("Sheet2").UsedRange.Rows.Count 'hier zal hij deze gegevens moeten naar toe brengen
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If

[Verwijderd]

Hij blijft steeds de rijden toevoegen onder de laatste rij in de doelsheet.
Hij vervang en of wijzigt niks

[skate master]

Als ik je goed begrijp Wil je je doelsheet updaten met de nieuwe"Nintendo"rijen in je bron.
Misschien handig dan om je doelsheet leeg te maken voordat je je kopieer activiteiten laat uitvoeren. Dit kan eenvoudig via VBA geregeld worden.

Hierdoor heb je altijd de actuele gegevens uit je bron.

[ Voor 11% gewijzigd door skate master op 06-08-2017 20:30 . Reden: Toevoeging ]

[Verwijderd]

Wat is de juiste Code hiervoor? kan deze niet meteen terugvinden..

[Harrie_]

Verwijderd schreef op zondag 6 augustus 2017 @ 19:41:
Hij blijft steeds de rijden toevoegen onder de laatste rij in de doelsheet.
Hij vervang en of wijzigt niks

Dit dus:

code:

xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)

Ik weet niet om hoeveel rows we praten maar als het er niet teveel zijn is het misschien een quick fix om Sheet2 eerst leeg te gooien en dan vanaf regel 1 in te gaan plakken?

[Verwijderd]

Dus dan dien ik steeds alles te verwijderen op sheet 2 alvorens in de macro kan gebruiken ?

code is momenteel het voglende

Sub NINTENDOOOO()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("PDC").UsedRange.Rows.Count 'bron waar hij de gegevens moet gaan zoeken
J = Worksheets("Sheet2").UsedRange.Rows.Count 'hier zal hij deze gegevens moeten naar toe brengen
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If

Set xRg = Worksheets("PDC").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "NINTENDO " Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("" & J + 1)
J = J + 1
End If
Next
End Sub

[Verwijderd]

Als je de laatste rij die je hebt verwerkt van je bron-sheet, en beginwaarde van J nou eens opslaat in aparte cellen, en die aan het begin van de nieuwe kopieeractie gebruikt om het geheel te initialiseren?

Dan kun je verder gaan bij de nieuwe rijen (zonder d) in de bron en kun je toevoegen in de tweede sheet onder de vorige toevoeging.

[Verwijderd]

Verwijderd schreef op maandag 7 augustus 2017 @ 13:41:
Dus dan dien ik steeds alles te verwijderen op sheet 2 alvorens in de macro kan gebruiken ?

code is momenteel het voglende

Sub NINTENDOOOO()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("PDC").UsedRange.Rows.Count 'bron waar hij de gegevens moet gaan zoeken
J = Worksheets("Sheet2").UsedRange.Rows.Count 'hier zal hij deze gegevens moeten naar toe brengen
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If

Set xRg = Worksheets("PDC").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "NINTENDO " Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("" & J + 1)
J = J + 1
End If
Next
End Sub

hoi detree,
Ik zie dat je de regels die je moest verwijderen niet verwijderd zijn.


doe dit maar

Sub NINTENDOOOO()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("PDC").UsedRange.Rows.Count 'bron waar hij de gegevens moet gaan zoeken
'J = Worksheets("Sheet2").UsedRange.Rows.Count 'hier zal hij deze gegevens moeten naar toe brengen
'If J = 1 Then
'If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
'End If
Worksheets("Sheet2").Cells.Clear
Set xRg = Worksheets("PDC").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "NINTENDO " Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

[Creepy]

Je opent een topic op de verkeerde plek (zie Client Software Algemeen) waarbij je niet aangeeft wat je nu zelf al hebt geprobeerd om je probleem op te lossen (iets wat we hier wel van je vragen). Nu kan ik je topic verplaatsen maar gezien de missende informatie en het helpdeskerige gedrag verplaats ik het niet maar sluit ik het.

[ Voor 7% gewijzigd door Creepy op 11-08-2017 13:12 ]