Mevcut kodda basit değişiklik gerekli...

[snake5500]

Merhaba.

Aşağıdaki kod ile aynı çalışma kitabındaki farklı sayfalardan veri çekmekteyim. Ben ise bu kodu düzenleyip farklı çalışma kitabından veri çekmek istiyorum (kapalı dosya değil, veri çekilecek çalışma kitabı daima açık kalacak). Aşağıdaki kodda bulunan "GELİR TAKİP" ve "GİDER TAKİP" çalışma sayfalarını, aynı çalışma kitabında değil de "İŞYERİ TAKİP" isimli bir çalışma kitabındaymış gibi varsayarak kodu düzenleyebilir misiniz? Diğer herşey aynı, sadece bu iki sheet, ismini verdiğim farklı çalışma kitabında olacak ve veriyi oradan çekecek.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, sat As Long
If Intersect(Target, [C6]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
On Error GoTo hata
Range("B9:G65536").ClearContents
sat = 9
Set s1 = Sheets("GİDER TAKİP")
For i = 4 To s1.Cells(65536, "F").End(xlUp).Row
    If LCase(Replace(Replace(Target.Value, "I", "ı"), "İ", "i")) = _
    LCase(Replace(Replace(s1.Cells(i, "F").Value, "I", "ı"), "İ", "i")) Then
    Cells(sat, "B").Value = s1.Cells(i, "G").Value
    Cells(sat, "C").Value = s1.Cells(i, "D").Value & " - " & s1.Cells(i, "E").Value
    Cells(sat, "D").Value = s1.Cells(i, "H").Value
    Cells(sat, "E").Value = s1.Cells(i, "I").Value
    Cells(sat, "F").Value = s1.Cells(i, "P").Value
    Cells(sat, "G").Value = s1.Cells(i, "S").Value
    Cells(sat, "H").Value = s1.Cells(i, "T").Value
    Cells(sat, "I").Value = s1.Cells(i, "N").Value
    sat = sat + 1
    End If
Next i
Set s2 = Sheets("GELİR TAKİP")
For j = 4 To s2.Cells(65536, "F").End(xlUp).Row
    If LCase(Replace(Replace(Target.Value, "I", "ı"), "İ", "i")) = _
    LCase(Replace(Replace(s2.Cells(j, "F").Value, "I", "ı"), "İ", "i")) Then
    Cells(sat, "B").Value = s2.Cells(j, "G").Value
    Cells(sat, "C").Value = s2.Cells(j, "D").Value & " - " & s2.Cells(j, "E").Value
    Cells(sat, "D").Value = s2.Cells(j, "H").Value
    Cells(sat, "E").Value = s2.Cells(j, "I").Value
    Cells(sat, "F").Value = s2.Cells(j, "P").Value
    Cells(sat, "G").Value = s2.Cells(j, "S").Value
    Cells(sat, "H").Value = s2.Cells(j, "T").Value
    Cells(sat, "I").Value = s2.Cells(j, "N").Value
    sat = sat + 1
    End If
Next j
hata:
Set s2 = Nothing
End Sub

 

[Orion1]

İlgili satırları aşağıdaki kodlarla değiştiriniz.
Dosya uzantısı değişikse onuda değiştiriniz.

Set s1 = Workbooks("İŞYERİ TAKİP.[B][COLOR="Red"]xlsx[/COLOR][/B]").Sheets("GİDER TAKİP")
Set s2 = Workbooks("İŞYERİ TAKİP.[B][COLOR="red"]xlsx[/COLOR][/B]").Sheets("GELİR TAKİP")