Farklı Dosyadan Arama Yapma-Aktarma,

Katılım
9 Haziran 2019
Mesajlar
162
Excel Vers. ve Dili
Office 2016 Eng.
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
 
Katılım
9 Haziran 2019
Mesajlar
162
Excel Vers. ve Dili
Office 2016 Eng.
@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

Altın Üye
Katılım
18 Nisan 2008
Mesajlar
758
Excel Vers. ve Dili
office2010
Kod:
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
 
Katılım
9 Haziran 2019
Mesajlar
162
Excel Vers. ve Dili
Office 2016 Eng.
Sn. @Ziynettin Bey sizi de uğraştırıyorum. Öncelikle özür dilerim.
CSS:
    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.
 
Katılım
23 Mart 2017
Mesajlar
41
Excel Vers. ve Dili
2010 TR
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.

 
Katılım
9 Haziran 2019
Mesajlar
162
Excel Vers. ve Dili
Office 2016 Eng.
@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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
25,340
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Alternatif;

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


Kod:
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

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
21,863
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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.:)
(y)(y)(y)
 
Katılım
9 Haziran 2019
Mesajlar
162
Excel Vers. ve Dili
Office 2016 Eng.
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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
25,340
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Kırmızı bölümleri değiştirmeniz yeterli olacaktır.

Rich (BB code):
With Range("B2:C" & Son)
Rich (BB code):
Range("B2:C" & Rows.Count).ClearContents
 
Üst