Verileri diğer sayfalara aktarılması hk.

[1903emre34@gmail.com]

Merhaba,

Sayfa1'de yer alan tarihleri yanındaki kelimeleri, sayfa2'den hemen yanlarına "I" sütünda aktarması kod ilave olarak nasıl değişiklik yapabilir miyiz, istenen sayfa2'de "I" sütünda manuel olarak yapılmıştır. (sarı ile boyanmıştır)

 

[Ziynettin]

Sub test()
Dim s1 As Worksheet, s2 As Worksheet, a()

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

Set dc = CreateObject("scripting.dictionary")
sutun = Range("AA1").Column

For j = 1 To sutun Step 2
    son = s1.Cells(Rows.Count, j + 1).End(3).Row
    If son > 2 Then
        a = s1.Range(s1.Cells(2, j), s1.Cells(son, j + 1)).Value
        For i = 2 To UBound(a)
            If a(i, 2) <> "" Then
                krt = a(i, 1) & "|" & a(1, 1)
                dc(krt) = a(i, 2)
            End If
        Next i
    End If
Next j

son = s2.Cells(Rows.Count, 1).End(3).Row
If son < 2 Then Exit Sub
a = s2.Range("A2:F" & son).Value
ReDim b(1 To UBound(a), 1 To 1)

For i = 1 To UBound(a)
    krt = a(i, 1) & "|" & a(i, 6)
    If dc.exists(krt) Then
        b(i, 1) = dc(krt)
    End If
Next i

s2.[i2].Resize(UBound(a)) = b
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[muygun]

Merhaba;
Alternatif:
Eki deneyin.
İyi çalışmalar.