kopieren naar ander tabblad

[muldertje2]

Hallo,

Bijgevoegd heb ik een voorbeeldbestand. Het is de bedoeling om middels een macro te of er een getal in kolom A van 'blad 1' staat. Indien ja, dan moet hij gaan zoeken of hij dat getal ook gaat vinden in de eerste kolom van 'blad 2'. Als hij die daar vindt, dan moet hij de gegevens die in de cellen E t/m G staan vanuit 'blad 1' kopieren naar de cellen E t/m G van 'blad 2'. Uiteraard achter het juiste nummer.

 Sub Selecterenceltbvopslaanfactureringsgegevens()


    Sheets("Blad 2").Select

    Dim x As Long, lastrow As Long
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    For x = lastrow To 1 Step -1
        If Cells(x, 1).Value = Sheets("Blad1").Range("A31") Then
            Sheets("Maak factuur").Select
            Range("E31:G31").Select
            Selection.Copy
            Sheets("Blad 2").Select
            Cells(x, 5).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        End If
    Next x

End Sub

Zo'n soort code heb ik nu. Maar het probleem is vooral dat ik dan telkens de code opnieuw moet laten uitvoeren. Dus eerst A3, dan A4, dan A5, dan A6, etc. Dit moet sneller en eenvoudiger kunnen lijkt mij. Wie weet de oplossing?

Bekijk bijlage Voorbeeldbestand.xls

 

[zapatr]

Sub macro1()
Dim r As Integer, lr1 As Integer, lr2 As Integer, mijnbereik As Range
'Deze code werd geschreven door Zapatr
With Sheets("Blad2")
lr2 = .Cells(Rows.Count, 1).End(xlUp).Row
Set mijnbereik = .Range(.Cells(3, 1), .Cells(lr2, 1))
End With
Range(mijnbereik.Offset(, 4), mijnbereik.Offset(, 6)).ClearContents
lr1 = Sheets("Blad1").Cells(Rows.Count, 1).End(xlUp).Row
For r = 7 To lr1
With Sheets("Blad1")
If .Cells(r, 1).Value > 0 Then
If WorksheetFunction.CountIf(mijnbereik, .Cells(r, 1)) > 0 Then
y = WorksheetFunction.Match(.Cells(r, 1), mijnbereik, 0)
For p = 4 To 6
mijnbereik.Cells(y, 1).Offset(, p) = .Cells(r, 1).Offset(, p)
Next p
End If
End If
End With
Next r
End Sub

 

[zapatr]

De code werd aangepast.
Gebruik de laatst geplaatste macro.

 

[muldertje2]

Ontzettend bedankt!
Dit is precies zoals ik wil lijkt me. Nu ben ik nog niet zo heel goed met macro's. Is het ook mogelijk om opmerkingen er tussen te zetten zodat ik weet wat het doet? Zodat ik even een aantal waardes en bereiken kan wijzigen. Het lukt me namelijk niet om dit een beetje te begrijpen.. En daarom te plaatsen in mijn eigen bestand.

De zoekwaarde van mij staat in blad "maak factuur" in kolom A. Vervolgens moeten de gegevens vanuit de cellen Y:BZ worden weggeschreven naar het blad "blad 4" de cellen BA:CD

Hopelijk dat je begrijpt wat ik bedoel.

 

[zapatr]

Ik heb bovenstaande macro herschreven zodat hij gemakkelijker te begrijpen is.
Deze macro is minder snel dan die van hierboven, maar dat zul je niet of nauwelijks merken. Waarom miner snel? Omdat ALLE rijen in Blad1 en Blad2 (in het bereik met gegevens) worden doorlopen, terwijl in de eerste macro alleen de cellen in kolom A waar wat in staat worden bekeken. Onderstaande macro kan aanmerkelijk worden ingekort, maar dat heb ik met opzet niet gedaan, zo zie je beter wat er gebeurt. Aan de hand hiervan zou je dit ook in jouw eigen bestand moeten kunnen toepassen. Succes ermee.

Sub macro2()
Dim x as integer, y as integer, lr1 as integer, lr2 as integer
[COLOR="#0000CD"]'Deze macro werd geschreven door Zapatr[/COLOR]

[COLOR="#0000CD"]'Bepaal de laatste rij in kolom A van Blad1 en Blad2[/COLOR]
lr1 = Sheets("Blad1").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Row

[COLOR="#0000CD"]'In Blad2 wissen: E3:G26, zodat er niets meer staat als je de macro een 2e keer uitvoert:[/COLOR]
Sheets("Blad2").Range("E3:G" & lr2).ClearContents

[COLOR="#0000CD"]'Met x wordt kolom A in Blad2 doorlopen vanaf A3[/COLOR]
For x = 3 To lr2

[COLOR="#0000CD"]'Met y wordt kolom A in Blad1 doorlopen vanaf A7[/COLOR]
    For y = 7 To lr1
    
       [COLOR="#0000CD"] 'Als in kolom A in Blad2 een waarde gelijk is aan een waarde in kolom A van Blad1[/COLOR]
        If Sheets("Blad2").Range("A" & x).Value = Sheets("Blad1").Range("A" & y).Value Then
        
           [COLOR="#0000CD"] 'Maak dan in beide bladen de cellen in de E-, F-, en G-kolom aan elkaar gelijk[/COLOR]
            Sheets("Blad2").Range("E" & x).Value = Sheets("Blad1").Range("E" & y).Value
            Sheets("Blad2").Range("F" & x).Value = Sheets("Blad1").Range("F" & y).Value
            Sheets("Blad2").Range("G" & x).Value = Sheets("Blad1").Range("G" & y).Value
        End If
    Next y
Next x
End Sub

 

[zapatr]

Let op de cursieve datum en tijd (in het bericht hierboven) waarop de macro werd aangepast!

 

[muldertje2]

Nogmaals hartelijk dank. De aanpassing heb ik gezien. Maar als het goed is moet ik juist die aanpassing niet hebben, want dan maakt hij blad 2 leeg. Dit moet juist niet. Hij mag wel overschrijven, maar niet bestaande gegevens van andere rijen verwijderen. Ik ben met behulp van de uitleg bij de laatste code er wel uitgekomen! Ik pas nu de allereerste code toe, en voor zover ik nu kan nagaan met volle tevredenheid! :thumb:

Opgelost!