Çoklu sütun yenilenen değer ?

[igultekin2000]

iyi akşamlar; tekli sütunlarda yenilenen değer olarak verileri başka sayfaya aktarıyorum. Sütun ikili ise makro düşeyara ile de karşılık değerini bulduruyorum. Kullandığım formül

Sub Yenilenendeger()
Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
Dim SO As Worksheet: Set SO = Sheets("Sayfa2")
Dim Sayfa2(), dizi()
Son = SD.Cells(Rows.Count, "H").End(3).Row
Sayfa2 = SD.Range("H2:H" & Son).Value
Set dic = CreateObject("scripting.dictionary")
For X = 1 To UBound(Sayfa2, 1)
aranan = Sayfa2(X, 1)
If Not dic.exists(aranan) Then
dic.Add aranan, ""
End If
Next X
SO.Range("A3:A" & Rows.Count).ClearContents
SO.Range("A3").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub


Sub Duseyara()
Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant

Set S1 = Sheets("Sayfa2")
Set S2 = Sheets("Sayfa1")

On Error Resume Next
For X = 1 To S1.Cells(Rows.Count, 1).End(xlUp).Row
Err.Clear
If S1.Cells(X, 1) <> "" Then
Veri = Application.WorksheetFunction. _
VLookup(S1.Cells(X, 1), S2.Range("H:I"), 2, 0)
If Err.Number = 0 Then
S1.Cells(X, 2) = Veri
Else
S1.Cells(X, 2) = ""
End If
End If
Next
Set S1 = Nothing
Set S2 = Nothing

'MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sütunlarda yenilenen değer olarak ikili vey daha fazla sütunu başka çalışma sayfasının daha pratik yolu var mıdır. ? teşekkür ederim.

 

[Ziynettin]

Bu şekilde deneyiniz.

Sub test()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim a(), b(), dic As Object, i As Long, say As Long
    Dim t1 As Date, t2 As Date, sat As Long
    Set s1 = Sheets("sayfa1")
    Set s2 = Sheets("sayfa2")
    Set dic = CreateObject("scripting.dictionary")
    a = s1.Range("A2:I" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    t1 = s2.[C1]: t2 = s2.[D1]
    ReDim b(1 To UBound(a), 1 To 6)
    For i = 1 To UBound(a)
        If Not dic.exists(a(i, 8)) Then
            dic(a(i, 8)) = dic.Count + 1
            say = dic.Count
            b(say, 1) = a(i, 8)
            b(say, 2) = a(i, 9)
            b(say, 3) = 0
            b(say, 5) = 0
            b(say, 6) = VBA.Format(t2, "mm.yyyy")
        End If
        sat = dic(a(i, 8))
        If a(i, 1) >= t1 And a(i, 1) <= t2 Then
            If IsNumeric(a(i, 5)) Then a(i, 5) = a(i, 5) Else a(i, 5) = 0
            b(sat, 3) = b(sat, 3) + a(i, 5)
            b(sat, 5) = b(sat, 3)
        End If
    Next i
    s2.Range("A3:I" & Rows.Count).ClearContents
    If say > 0 Then
        s2.[F3].Resize(say).NumberFormat = "@"
        s2.[A3].Resize(say, 6) = b
    End If
    MsgBox "İşlem bitti.", vbInformation
End Sub

 

[igultekin2000]

iyi akşamlar;

  b(sat, 3) = b(sat, 3) + a(i, 5)

bu satır hata veriyor,

 

[Ziynettin]

Tekrar deneyiniz.

 

[igultekin2000]

Teşekkürler, işlem kısalarak sonuçlanmış. Sorunsuz çalışıyor, iyi çalışmalar