Veri Aktarma

[metin_0606]

İŞTEN ÇIKIŞ SAYFASINA YAZDIĞIM VERİLERİ TC KİMLİK NUMARASINA GÖRE ANA SAYFADA PERSONELİ BULUP VERİLERİ İLGİLİ SÜTUNA AKTARMASINA İSTİYORUM. ANCAK MÜKERRER KAYITI DİKKATE ALMALI. AYNI PERSONEL DAHA ÖNCEDEN İŞE GİRİŞ-ÇIKIŞ YAPMIŞ OLABİLİR. DEĞERLİ HOCALARIM DESTEKLERİNİZİ BEKLİYORUM

 

[Orion1]

VBE şifreli.

 

[metin_0606]

VBE şifreli.

Kusura bakmayın hocam yeniden yükledim

 

[Orion1]

Buyurun.

Sub aktar_59()
Dim sh As Worksheet, k As Range
Set sh = Sheets("ANA SAYFA")
Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A2").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    sh.Cells(k.Row, "K").Value = Range("B2").Value
    sh.Cells(k.Row, "L").Value = Range("C2").Value
    sh.Cells(k.Row, "X").Value = Range("D2").Value
End If
MsgBox "BİTTİ"
End Sub

 

[metin_0606]

Buyurun.

Sub aktar_59()
Dim sh As Worksheet, k As Range
Set sh = Sheets("ANA SAYFA")
Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A2").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    sh.Cells(k.Row, "K").Value = Range("B2").Value
    sh.Cells(k.Row, "L").Value = Range("C2").Value
    sh.Cells(k.Row, "X").Value = Range("D2").Value
End If
MsgBox "BİTTİ"
End Sub

Evren hocam kod için öncelikle teşekküler işten çıkış sayfasına örneğin 20 kişi ekleyip toplu aktar yaptığımda makro çalışmadı

 

[Orion1]

Evren hocam kod için öncelikle teşekküler işten çıkış sayfasına örneğin 20 kişi ekleyip toplu aktar yaptığımda makro çalışmadı

Buyurun.

Sub aktar_59()
Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Set sh = Sheets("ANA SAYFA")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
    Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A2").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        sh.Cells(k.Row, "K").Value = Range("B" & i).Value
        sh.Cells(k.Row, "L").Value = Range("C" & i).Value
        sh.Cells(k.Row, "X").Value = Range("D" & i).Value
    End If
Next
MsgBox "BİTTİ"
End Sub

 

[metin_0606]

Buyurun.

Sub aktar_59()
Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Set sh = Sheets("ANA SAYFA")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
    Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A2").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        sh.Cells(k.Row, "K").Value = Range("B" & i).Value
        sh.Cells(k.Row, "L").Value = Range("C" & i).Value
        sh.Cells(k.Row, "X").Value = Range("D" & i).Value
    End If
Next
MsgBox "BİTTİ"
End Sub

[/Q
Evren Hocam makro hata vermiyor ama toplu aktarmada yapmıyor

 

[Orion1]

İlgili satırı aşağıdaki ile değiştirin.

Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)

 

[metin_0606]

İlgili satırı aşağıdaki ile değiştirin.

Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)

Sub aktar_59()
Dim sh As Worksheet, k As Range, sonsat As Long, i As Long
Set sh = Sheets("ANA SAYFA")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
Set k = sh.Range("C3:C" & Rows.Count).Find(Range("A" & i).Value, , xlValues, xlWhole)
If Not k Is Nothing Then
sh.Cells(k.Row, "K").Value = Range("B" & i).Value
sh.Cells(k.Row, "L").Value = Range("C" & i).Value
sh.Cells(k.Row, "X").Value = Range("D" & i).Value
End If
Next
MsgBox "BİTTİ"
End Sub

Makronun son şekli bu yine çalışmadı evren hocam

 

[Orion1]

İlgili satırı aşağıdaki ile değiştirin.
Baştan 2 satır elle girseydiniz bunlar olmayacaktı.

sonsat = Cells(Rows.Count, "A").End(xlUp).Row

 

[metin_0606]

İlgili satırı aşağıdaki ile değiştirin.
Baştan 2 satır elle girseydiniz bunlar olmayacaktı.

sonsat = Cells(Rows.Count, "A").End(xlUp).Row

Hocam çok teşekkür ederim şimdi oldu bize personel kısmından liste bazen toplu çıkış şeklinde geliyor ilgili kısımları benim işten çıkış sayfama kopyala yapıştır yapacağım için bu kod bana daha uygun herşey için teşekkür ederim