Farklı Dosyadan Arama Yapma-Aktarma,

[Utekiner]

Merhaba;

Bir klasörüm içerisinde 2 adet excel dosyası bulunmaktadır. Biri kapalı diğeri ise açık durumda iken dosyada arama yapma ve kapalı dosyadaki bilgilerin açık olan sayfaya aktarmasını istiyorum. Nasıl yapılabilir.

Dosya: Ara Aktar

 

[Ziynettin]

Dosyalarınız aynı klasörde olmalı.

https://www.dosyaupload.com/j7cm

 

[Utekiner]

@Ziynettin Bey emeğinize sağlık çok teşekkür ederim.
Şöyle bir durum olur ise "kapalı dosyadan sadece D - F sütununa ait bilgilerin aktarılmasını istersem". yazmış olduğunuz kodda nasıl bir değişiklik yapmalıyım.

 

[Ziynettin]

Private Sub CommandButton1_Click()
Z = TimeValue(Now)
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "Close_Excel.xlsx"
GetObject (yol & dosya)
Set dic = CreateObject("scripting.dictionary")
Set s1 = Workbooks(dosya).Sheets("Sheet1")
    a = s1.Range("A2:AG" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    sutun = 3
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        dic(krt) = i
    Next i
Set s2 = Workbooks(ThisWorkbook.Name).Sheets("sheet1")
aa = s2.Range("A2:A" & s2.Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(aa), 1 To sutun)
    For i = 1 To UBound(aa)
        krt = CStr(aa(i, 1))
        If dic.exists(krt) Then
            For j = 1 To sutun
                b(i, j) = a(dic(krt), j + 3)
            Next j
        End If
    Next i
    s2.[D2].Resize(UBound(aa), sutun) = b
    Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox CDate(TimeValue(Now) - Z)
End Sub

 

[Utekiner]

Sn. @Ziynettin Bey sizi de uğraştırıyorum. Öncelikle özür dilerim.

    sutun = UBound(a, 2) - 1
                b(i, j) = a(dic(krt), j)
    s2.[B2].Resize(UBound(aa), sutun) = b

Bu satırlarda değişiklik yaptığınızı gördüm. Benim asıl öğrenmeye çalıştığım. Kapalı sayfadaki herhangi bir sütunların bilgilerini almak istersem kodun hangi kısmında revize yapmam gerektiğidir.

 

[muratboz06]

Alternatif bir çözüm iki excel dosyasını açınız. Open Excelde Düşeyara fonksiyonun kullanınız. Tablo dizisine Close Exceldeki tabloyu seçip sabitleyiniz.
Daha sonra Close Exceli kapatabilirsiniz.

 

[Utekiner]

@muratboz06 Bey formül ile yapılacak bir işlem değil malesef, sebebi aranan değer sayısı 500 den daha fazla olacak ve Kapalı dosyada ise veri 1.000 - 10.000 civarında satır ve sütun içerisinde arayacağından dolayı excel kasacak ve patlayacak. İNDİS-KAÇINCI gibi işlevler ile veri alabiliyorum. İlginiz için teşekkür ederim. Ziynettin Bey'in yazmış olduğu kodlar çok hızlı aktarıyor. Sadece belirli sütun aktarımlarında koddaki revize edilmesi gereken yerleri öğrenmem yeterli olacaktır.

 

[Korhan Ayhan]

Alternatif;

B1 ve C1 hücrelerindeki başlıkları kapalı dosyadaki başlıklar ile aynı yazarsanız kod sorunsuz sonuç verecektir.

Option Explicit

Sub Veri_Aktar()
    Dim Yol As String, Son As Long
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Son = Cells(Rows.Count, 1).End(3).Row
        
    Range("B2:C" & Rows.Count).ClearContents
        
    With Range("B2:C" & Son)
        .Formula = "=INDEX('" & Yol & "[Close_Excel.xlsx]Sheet1'!$A:$AD,MATCH($A2," & "'" & Yol & _
                   "[Close_Excel.xlsx]Sheet1'!$A:$A,0),MATCH(B$1,'" & Yol & "[Close_Excel.xlsx]Sheet1'!$1:$1,0))"
        .Value = .Value
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Veri aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Orion1]

Korhan hocam yine süper bir kod yazmışsınız.
Ben denedim başka bir dosyada.
Kapalı dosyayı açmadan index ve match formüllerinin kullanımı iş görüyor.
İyi geceler.

 

[Utekiner]

Sn. @Korhan Ayhan Bey öncelikle teşekkür ederim. Alternatif paylaşım için. Öğrenmek istediğim D1 - E1 - F1 ... açık dosyaya sütunları da eklemek istersem eğer sizin yazmış olduğunuz kodda ne gibi değişiklikler yapmam gerekir.

 

[Korhan Ayhan]

Kırmızı bölümleri değiştirmeniz yeterli olacaktır.

With Range("B2:C" & Son)

Range("B2:C" & Rows.Count).ClearContents