Soru DüşeyAra ve Metin Birleştir (Farklı Excellerden)

[leonadies]

Üstadlar Merhaba;

3 Adet dosyam var. Bunlardan ANA EXCEL isimli dosyada var olan fiş numaralarının karşısına YAVRU EXCEL 1 ve YAVRU EXCEL 2 isimli dosyalardaki karşılığını bulup Makro ile yan yana birleştirerek yazdırmak istiyorum..

Yol kurgusu dinamik tanımlanırsa çok sevinirim. Yapılabilir mi?

 

[leonadies]

Çözüm olmaz mı arkadaşlar?

 

[umutak]

Merhaba
Ekte bir çalışmam var umarım işinizi görür.

 

[leonadies]

Üstadım teşekkür ederim ancak makro ile çözüme ihtiyacım var

 

[leonadies]

dış kaynaklardan düşeyara yapmalı yaparkende birleştirme yapmalı. Bu şekilde çözülür zannımca. İyi bilsem yazardım

 

[Korhan Ayhan]

"Yavru excel" dosyalarınızı bir klasör altına almanız mümkün mü?

 

[leonadies]

Malesef @Korhan Ayhan hocam. Kurgum bu şekilde olmak durumunda (yani mecburiyetten)

 

[Korhan Ayhan]

Deneyiniz.

 

[leonadies]

Sayın @Korhan Ayhan hocam ellerinize sağlık gerçekten harika. Sadece klasör yolunu sormak yerine yol tanımlamak şeklinde yapabilsek harika olacak. Veriler ağ üzerinde bir klasör altında olacak. Masaüstünde asla veri olmayacak.
Çok teşekkür ederim

 

[Korhan Ayhan]

Yol esnek olsun diye belirttiğiniz için seçmeli şekilde düzenlemiştim.

Kod içindeki aşağıdaki bölümü istediğiniz gibi düzenleyip kullanabilirsiniz.

Kaynak_Klasor = "C:\Belgelerim\"

Option Explicit

Dim Kaynak_Klasor As String, Alt_Klasor As Object
Dim Dosyalar As Object, Dosya As Variant
Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
Dim S1 As Worksheet, Veri As Range, Zaman As Double

Sub Verileri_Aktar()
    Zaman = Timer
  
    Kaynak_Klasor = "C:\Belgelerim\"
 
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Veri")
  
    S1.Range("F2:F" & S1.Rows.Count).ClearContents
  
    Call Listele(Kaynak_Klasor, True)
      
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
  
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Sub Listele(Yol As String, Alt_Klasorler_Dahil As Boolean)
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).Files
  
    For Each Dosya In Dosyalar
        If InStr(1, Dosya, "$") = 0 Then
            If Dosya <> ThisWorkbook.FullName Then
                Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
              
                For Each Veri In S1.Range("D2:D" & S1.Cells(S1.Rows.Count, 4).End(3).Row)
                    Sorgu = "Select * From [Kayıt$A:E] Where F1=" & Veri.Value & " And F5 Is Not Null"
                    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                    If Kayit_Seti.RecordCount > 0 Then
                        Veri.Offset(0, 2) = Veri.Offset(0, 2) & " " & Kayit_Seti.Fields(4)
                    End If
                    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
                Next
            End If
        End If
    Next

    If Baglanti.State <> 0 Then Baglanti.Close

    On Error Resume Next
  
    If Alt_Klasorler_Dahil Then
        For Each Alt_Klasor In CreateObject("Scripting.Filesystemobject").GetFolder(Yol).SubFolders
            Call Listele(Alt_Klasor.Path, True)
        Next
    End If
  
    On Error GoTo 0

    Set Dosyalar = Nothing
End Sub