create a summary

[Ger]

Good morning,

i'm looking for a way to create a summary.
I've a list of date that a person followed a training and a list of persons that must follow the training.
i'm looking for a way to copy the date a training (gegevens) to the list of persons (ovz).

Keyfield is pers.nr.

see attachment.


Thx,
Ger

[SamT]

Sub TransferDates()
'for help, see: "http://www.vbaexpress.com/forum/showthread.php?53527-create-a-summary"
Dim GegPersNr As Range
Dim OvzPersNr As Range
Dim Cel As Range

Set GegPersNr = Sheets("gegevens").Range(Range("A2"), Range("A2").End(xlDown))
Set OvzPersNr = Sheets("ovz").Range(Range("A2"), Range("A2").End(xlDown))

OnError GoTo Message

For Each Cel In GegPersNr
Cel.Offset(0, 1).Copy OvzPersNr.Find(Cel).End(xlToRight)
Next Cel

Exit Sub
Message:
MsgBox "Pers.Nr " & Cel.Value & " not found "

End Sub

[Ger]

SamT,

error message on set GegPersNr.


Ger

[Ger]

Sub TransferDates()
'for help, see: "http://www.vbaexpress.com/forum/showthread.php?53527-create-a-summary"
Dim GegPersNr As Range
Dim OvzPersNr As Range
Dim Cel As Range
Set Sh = Sheets("gegevens")
Set Sh2 = Sheets("ovz")
Set GegPersNr = Sh.Range("A2:A24")
Set OvzPersNr = Sh2.Range("A2:A16")

On Error GoTo Message

For Each Cel In GegPersNr
Cel.Offset(0, 1).Copy OvzPersNr.Find(Cel).End(xlToRight)
Next Cel

Exit Sub
Message:
MsgBox "Pers.Nr " & Cel.Value & " not found "

End Sub


This code runs but copies only 1 date (the last) to each persnr in ovz in column c and not date 1 to column d, date 2 to column e, date 3 to column f etc.

Ger

[snb]

@Ger,

Volgens mij kun je veel eenvoudiger op helpmij.nl je vraag stellen.

[Ger]

zal ik doen.

[snb]

Sub M_snb()
sn = Sheets("gegevens").Cells(1).CurrentRegion
sp = Sheets("ovz").Cells(1).CurrentRegion

With CreateObject("scripting.dictionary")
For j = 2 To UBound(sn)
.Item(sn(j, 1)) = .Item(sn(j, 1)) & "_" & sn(j, 2)
Next

For j = 2 To UBound(sp)
If .exists(sp(j, 1)) Then Sheets("ovz").Cells(j, 4).Resize(, UBound(Split(.Item(sp(j, 1)), "_"))) = Split(Mid(.Item(sp(j, 1)), 2), "_")
Next
End With
End Sub

[Ger]

Snb,

Thx.
This works fine.


Ger
PS zal post in helpmij op afgehandeld zetten.

[SamT]

This code runs but copies only 1 date (the last) to each persnr in ovz in column c and not date 1 to column d, date 2 to column e, date 3 to column f etc.

I'm sorry, that was my bad for not fully testing it. It was copying all dates to the same column.

For Each Cel In GegPersNr
Cel.Offset(0, 1).Copy OvzPersNr.Find(Cel).End(xlToRight).Offset(0, 1)
Next Cel