Cellen kopieren wanneer aan voorwaarde voldaan wordt

[edsel_nl]

Beste lezers,

Ik loop tegen nog een probleem aan. Wanneer de waarde in een cel van kolom B3:20 gelijk is aan de waarde in C1 dient hij de betreffende waarde in kolom A en C te kopiëren naar de cellen B1 en B2 in het tabblad "Email". Deze gegevens worden dan gebruikt om een email op te stellen. Vervolgens dient hij verder te zoeken naar de volgende overeenkomst om weer de betreffende waarde in kolom A en C te kopiëren naar de cellen B1 en B2 in het tabblad "Email" enz. enz.

Om het wat duidelijker te maken heb ik een voorbeeld opgenomen in de bijlage.

De onderstaande code is hier al in verwerkt.

Sub Rechthoek1_Klikken()
Application.ScreenUpdating = False
For rij = 3 To 20
If Cells(rij, 2) = Range("C1") Then
'Hier dient een code te komen om de waarde te kopieren naar het andere werkblad
'Normaal gesproken heb ik hier dan ook de code voor het mailen staan die de gegevens in de cellen B1 en B2 van het werkblad "Email" gebruikt voor het mailtje
End If
Next rij

End Sub

 

[danny147]

Beste edsel_nl

Deze week zijn er al 2 vragen gesteld over dit probleem.

Een ervan is deze.

Groetjes Danny. :thumb:

 

[danny147]

Beste edsel_nl

Kon het niet laten ziehier de code.

Sub Naaremail()
    Application.ScreenUpdating = False
   Dim c As Range
   For Each c In [B2:B1000]
        If c = [C1] Then
            c.Offset(0, 1).Copy
            ['Email'!B65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Groetjes Danny. :thumb:

 

[edsel_nl]

Beste Danny,

Bedankt voor de link. :thumb: Er zijn inderdaad al een aantal vragen over gesteld. Alleen naar mijn weten gaan die voornamelijk over het kopiëren van een hele rij naar de eerste lege rij in een ander werkblad. Voor iemand zoals ik die er niet bijster veel verstand van VBA heeft is het dan lastig om een dergelijke code om te vormen naar een oplossing van het probleem van mij.

Beste edsel_nl

Deze week zijn er al 2 vragen gesteld over dit probleem.

Een ervan is deze.

Groetjes Danny. :thumb:

 

[danny147]

Beste edsel_nl

Zie topic hierboven van mij, heb hem aangepast wegens fout erin.

Groetjes Danny. :thumb:

 

[edsel_nl]

Zo dat gaat snel bedankt Danny :thumb: :thumb:

De code werkt maar nog niet helemaal zoals ik graag zou willen. De waarden in de cellen van kolom A en C van het tabblad "invoer" per rij naar naar de cellen B1 en B2 in het andere tabblad "email". De waarden mogen steeds dus over elkaar heen geplakt worden omdat ik er zelf de code voor het mailen aan er nog aan toe voeg. Deze heb ik expres niet opgenomen om het voorbeeld wat duidelijker te houden.

 

[danny147]

Beste edsel_nl

Heb het gevonden.
Heb het tabblad Email lichtjes gewijzigd want als er 2 personen zijn met hetzelfde nummer kan ik deze beide niet in cel B2 plaatsen, daarom dan maar naast elkaar.
Hopelijk kan je hier mee leven.

Sub Naaremail()
    Application.ScreenUpdating = False
   Dim c As Range
   Dim d As Range
   Sheets("Email").Range("B2:C10") = ""
   For Each c In [B2:B1000]
        If c = [C1] Then
            c.Offset(0, 1).Copy
            ['Email'!B65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
   For Each d In [B2:B1000]
        If d = [C1] Then
            d.Offset(0, -1).Copy
            ['Email'!C65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Groetjes Danny. :thumb:

 

[edsel_nl]

Super bedankt Danny hier gaat het me zeker mee lukken, weer wat geleerd. :thumb:

 

[trucker10]

Met deze gaat dat ook werken

Sub Naaremail()
    Application.ScreenUpdating = False
   Dim c As Range
   For Each c In [B2:B1000]
        If c = [C1] Then
            c.Offset(0, -1).Copy
            ['Email'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
         If c = [C1] Then
            c.Offset(0, 1).Copy
            ['Email'!B65536].End(xlUp).Offset(1, 0).Insert Shift:=xlDown
        End If
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

@ Danny , ik had hem er maar in te trappen let ook op de email adressen hoe ze overkomen

 

[Warme bakkertje]

Zo lukt het wel in de opzet van TS

 

[trucker10]

Zo lukt het wel in de opzet van TS

Rudi , waarschijnlijk heb je iets over het hoofd gezien : als er 2 of meerdere adressen moeten overgebracht worden . Ik heb voorbeeld van TS staan er bij het cijfer 4 "Piet" en "Eva" er komt er maar eentje over .

 

[danny147]

Beste trucker10

Ze staan niet netjes gerangschikt in tabblad Email en als je een ander code neemt, moet hij het vorige email adres en naam verwijderen alvorens een nieuwe te plaatsen.

Dus code [Email!B1:B2].ClearContents ontbreekt hier.

Beste Warme bakkertje

Bij code 4 geeft hij op tabblad Email maar 1 naam weer nl. Eva terwijl het er 2 namen moeten zijn nl. Eva en Piet

Voor leek te zijn in VBA vond ik het vrij geslaagd wat betreft de code, zolang TS maar tevreden is.

Groetjes Danny. :thumb:

 

[trucker10]

Beste trucker10

.

Dus code [Email!B1:B2].ClearContents ontbreekt hier.

Voor leek te zijn in VBA vond ik het vrij geslaagd wat betreft de code, zolang TS maar tevreden is.

Groetjes Danny. :thumb:

tussen een for next een clearcontents zetten , plakken > wissen > plakken ?
Je bent goed opweg , al beter dan mij in de vba :thumb:

 

[trucker10]

@ Danny of Rudi , deze nog een beetje bijstellen aangepast naar deze code

Sub Naaremail()
    Application.ScreenUpdating = False
   Dim c As Range
   [Email!B1:B10].ClearContents
   For Each c In [B3:B1000]
        If c = [C1] Then
            Union(c.Offset(0, -1), c.Offset(0, 1)).Copy
            ['Email'!B65536].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        End If
        
    Next
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

 

[Warme bakkertje]

Jongens, lees de vraag eens goed door. TS wil de eerste naam ophalen en versturen via mail. Daarna tweede naam ophalen en versturen, enz ....Het is dus niet de bedoeling om alle namen in 1 keer op te halen. Als je dus mijn code met F8 doorlopen had zou je gezien hebben dat dit wel degelijk gebeurd. Daarom ook de opmerking in de code waar de emailcode moet komen alvorens de volgende naam op te halen.

 

[trucker10]

Rudi GROOT gelijk heb je ik heb niet gelezen wat er stond

 

[edsel_nl]

Zo dat gaat helemaal snel! Bedankt allemaal. :thumb:

De code van Rudi komt geheel overeen met wat ik voor ogen had. Nu hoef ik zelf helemaal niet meer te prutsen.