Numaraları eşleştirerek Kapalı dosyadan veri alma ve işleme

[Feylosof]

İyi geceler,
"Kaynak Dosyan"ın "B" Sütunu ile "Hedef Dosya"nın "E" sütunlarında eşleşen numaralardan "E" ve "F" sütunlarındaki verileri "HEDEF DOSYA"nın "I" ve "j" sütunlarına çekecek koda ihtiyacım var. Örnek dosyalar ektedir. Yardımlarını esirgemeyecek olan siz EXCEL dostlarına minnettar olurum.

 

[Haluk]

ADO ile bir alternatif ektedir...

.

 

[Feylosof]

Sayın @Haluk hızlı ve kesin çözüm için çok teşekkür ederim. Sağ olun, emeğinize sağlık...

 

[Feylosof]

ADO ile bir alternatif ektedir...

.

@Haluk Bey kod ile alakalı bir durum fark ettim sonradan. Veri çekme işlemini iki dosyadaki öğrenci numaraları eşleştirerek. Birinci dosyada olan numaraları ikinci dosyadaki numaralarda bulup verileri karşısına yazacak. Burada kaynak dosyada var olan dosyaların tümünü alıp ikinci dosyada yukarıdan aşağıya doğru yapıştırıyor. Dolayısıyla bilgileri yanlış kişilerin karşısına yazmış oluyor. özetle birinci dosyada olup ikinci dosyada olmayan numaraları es geçecek var olan aynı numaranın karşısına yazacak. İnşallah doğru anlatabildim. Bu kısmı çözerseniz duacınız olurum. Saygıyla

 

[Haluk]

Deneyiniz.....

(7 No'lu mesajdaki açıklamayı da okuyun....)

.

 

[Korhan Ayhan]

Alternatif;

DÜŞEYARA fonksiyonu makro olarak uygulanmıştır.

Option Explicit

Sub Aktar()
    Dim Dosya_Yolu As String, Son As Long, Zaman As Double

    Zaman = Timer

    Application.ScreenUpdating = False

    Dosya_Yolu = ThisWorkbook.Path & Application.PathSeparator & "[KAYNAK DOSYA.xlsm]Sheet1"

    Son = Cells(Rows.Count, 5).End(3).Row

    With Range("I2")
        .Resize(Rows.Count - 1).ClearContents
        .Resize(Son).Formula = "=IFERROR(VLOOKUP(E2,'" & Dosya_Yolu & "'!$B:$F,4,0),"""")"
        .Resize(Son).Value = .Resize(Son).Value
    End With
    
    With Range("J2")
        .Resize(Rows.Count - 1).ClearContents
        .Resize(Son).Formula = "=IFERROR(VLOOKUP(E2,'" & Dosya_Yolu & "'!$B:$F,5,0),"""")"
        .Resize(Son).Value = .Resize(Son).Value
    End With

    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Haluk]

@Feylosof ;

Dosyalar karışmasın diye, 5 No'lu mesajımdaki dosya isimlerinin sonuna 2 eklemiştim ama kodda bunu değiştirmeyi unutmuşum.

Siz, aşağıdaki düzenlemeyi yaparsınız...

    adoCN.ConnectionString = ThisWorkbook.Path & "\KAYNAK DOSYA2.xlsm"

.

 

[Korhan Ayhan]

Bu da başka bir alternatif;

İNDİS+KAÇINCI fonksiyonlarının makro karşılığıdır.

Option Explicit

Sub Aktar()
    Dim Dosya_Yolu As String, Son As Long, Zaman As Double

    Zaman = Timer

    Application.ScreenUpdating = False

    Dosya_Yolu = ThisWorkbook.Path & Application.PathSeparator & "[KAYNAK DOSYA.xlsm]Sheet1"

    Son = Cells(Rows.Count, 5).End(3).Row

    With Range("I2")
        .Resize(Rows.Count - 1).ClearContents
        .Resize(Son).Formula = "=IFERROR(INDEX('" & Dosya_Yolu & "'!$E:$E,MATCH(E2,'" & Dosya_Yolu & "'!$B:$B,0)),"""")"
        .Resize(Son).Value = .Resize(Son).Value
    End With
    
    With Range("J2")
        .Resize(Rows.Count - 1).ClearContents
        .Resize(Son).Formula = "=IFERROR(INDEX('" & Dosya_Yolu & "'!$F:$F,MATCH(E2,'" & Dosya_Yolu & "'!$B:$B,0)),"""")"
        .Resize(Son).Value = .Resize(Son).Value
    End With

    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[Feylosof]

@Feylosof ;

Dosyalar karışmasın diye, 5 No'lu mesajımdaki dosya isimlerinin sonuna 2 eklemiştim ama kodda bunu değiştirmeyi unutmuşum.

Siz, aşağıdaki düzenlemeyi yaparsınız...

    adoCN.ConnectionString = ThisWorkbook.Path & "\KAYNAK DOSYA2.xlsm"

.

@Haluk Bey müteşekkirim. Varolun

 

[Feylosof]

Bu da başka bir alternatif;

İNDİS+KAÇINCI fonksiyonlarının makro karşılığıdır.

Option Explicit

Sub Aktar()
    Dim Dosya_Yolu As String, Son As Long, Zaman As Double

    Zaman = Timer

    Application.ScreenUpdating = False

    Dosya_Yolu = ThisWorkbook.Path & Application.PathSeparator & "[KAYNAK DOSYA.xlsm]Sheet1"

    Son = Cells(Rows.Count, 5).End(3).Row

    With Range("I2")
        .Resize(Rows.Count - 1).ClearContents
        .Resize(Son).Formula = "=IFERROR(INDEX('" & Dosya_Yolu & "'!$E:$E,MATCH(E2,'" & Dosya_Yolu & "'!$B:$B,0)),"""")"
        .Resize(Son).Value = .Resize(Son).Value
    End With
   
    With Range("J2")
        .Resize(Rows.Count - 1).ClearContents
        .Resize(Son).Formula = "=IFERROR(INDEX('" & Dosya_Yolu & "'!$F:$F,MATCH(E2,'" & Dosya_Yolu & "'!$B:$B,0)),"""")"
        .Resize(Son).Value = .Resize(Son).Value
    End With

    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Sayın @Korhan Ayhan desteğinizden dolayı çok teşekkür ederim. Varolun. Arşivimde saklı kalacak.