Hücrede yazan çalışma kitabı adına uyan çalışma kitabını açma

[kemal turan]

Merhaba,
Aşağıda yazan dosya yolundaki DENEME.xlsm çalışma kitabının adı gönder.xlsm çalışma kitabının "k1" hücresinde yazıyor.
"K1" hücresinde yazan çalışma kitabını aşağıda belirtilen dosya yolunda bulup açarak aşağıdaki istek kod daki işlemleri yapacak.
istek kod = önce gönder.xlsm çalışma kitabının "I" sutunun da "X" yazanları filtreleyecek, gidip çalışma deneme.xlsm dosyasını açıp filtrelenen verileri aktaracak.
aktarma şekli
gönder.xlsm "B" sutununu >>deneme.xlsm "J" Sutununa
gönder.xlsm "C" sutununu >>deneme.xlsm "C" Sutununa
gönder.xlsm "D" sutununu >>deneme.xlsm "D" Sutununa
gönder.xlsm "E" sutununu >>deneme.xlsm "G" Sutununa
gönder.xlsm "F" sutununu >>deneme.xlsm "H" Sutununa
gönder.xlsm "G" sutununu >>deneme.xlsm "I" Sutununa
aktarıp deneme.xlsm dosyasını save edip kapatacak.
Teşekkür edrim.

dosya yolu = "\\Server\logo\TENDATA GELEN VERILER\SATICI SAYFALARINA GÖDERİLECEK VERİLER\DENEME.xlsm"

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu gönder.xlsm isimli dosyadaki bir modüle kopyalayıp deneyiniz.
Not: Kodu kullanmadan önce her ihtimale karşı dosyalarınızın yedeğini alınız.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim w1 As Workbook
Dim yol As String, dsy As String, ara As String
Dim a As Long, s As Long, x As Long
Dim hdf As Range

ara = "X"
Set s1 = ThisWorkbook.ActiveSheet

s = WorksheetFunction.CountIf(s1.Range("I:I"), ara)
If s = 0 Then
    MsgBox "Aktarılacak veri (" & ara & ") bulunamadı."
    Exit Sub
Else
    ReDim dz(1 To s, 1 To 8)
End If

yol = "\\Server\logo\TENDATA GELEN VERILER\SATICI SAYFALARINA GÖDERİLECEK VERİLER\"
dsy = s1.Range("K1").Text

On Error Resume Next
Set w1 = Workbooks(dsy)
On Error GoTo 0
If w1 Is Nothing Then
    If (Dir(yol & dsy)) <> "" Then
        Set w1 = Workbooks.Open(yol & dsy)
    Else
        MsgBox yol & " konumunda " & dsy & " isimli bir dosya yer almıyor.", vbCritical
        Exit Sub
    End If
End If
Set s2 = w1.Sheets(1)

Set hdf = s2.Cells(s2.Rows.Count, "C").End(3)(2, 1).Resize(UBound(dz), UBound(dz, 2))
dz = hdf.Value
For a = 2 To s1.Cells(s1.Rows.Count, "I").End(3).Row
    If s1.Cells(a, "I").Value = ara Then
        x = x + 1
        dz(x, 1) = s1.Cells(a, "C")
        dz(x, 2) = s1.Cells(a, "D")
        dz(x, 5) = s1.Cells(a, "E")
        dz(x, 6) = s1.Cells(a, "F")
        dz(x, 7) = s1.Cells(a, "G")
        dz(x, 8) = s1.Cells(a, "B")
    End If
Next
hdf.Value = dz
w1.Close 1
MsgBox "İşlem tamam."
End Sub

 

[kemal turan]

Merhaba,
Biraz rahatsızım şirkete gittiğimde en kısa sürede dönüş yapacağım.
Çok teşekküre ederim. Emeğinize sağlık
Selametle kalınız

 

[kemal turan]

Ömer hocam çok teşekkür ederim.
Selametle kalınız.