• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İki ayrı dosyadaki verileri tek dosyada alt alta birleştirme

mekist

Altın Üye
Katılım
13 Ağustos 2008
Mesajlar
355
Excel Vers. ve Dili
Office 365 ProPlus-Türkçe
Merhaba,

İki ayrı dosyam var içerisindeki bilgileri tek excel kitabında birleştirmek istiyorum. önce festival olan dosyadakiler gelsin daha sonrada dentmed'deki dosyadaki veriler alt alta gelecek şekilde yeni bir kitapta birleştirmek istiyorum.
Örnek dosyalara baktım ama uyarlayamadım.
Yardımcı olabilir misiniz.
 

Ekli dosyalar

Merhaba,

Tam 2 ay sonra yanıt alıyorsunuz. Bunun nedeni sorunuzu ilgili olmayan yerde sormanız.

Konu tarafımdan Makro bölümüne aktarıldı.

Sorunuzun çözümüne gelince, bir çok çözüm yolu olabilir. Ben şöyle düşündüm :

1 yada 2 dosya ile sınırlı kalmamak için birleştirilecek dosyaları seçerek tamam dediğinizde ListBoxa alıp Listboxta çift tıkladığınız dosyayı ilgili dosyaya aktarır.

Kod:
Private Sub CommandButton1_Click()
    ListBox1.Clear
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Dim SecilenDosyalar As Variant
    With fd
        .Filters.Clear
'        .Filters.Add "All files", "*.*"
        .Filters.Add "Excel Dosyaları", "*.xls; *.xls; *.xlsx", 1
        If .Show = -1 Then
            For Each SecilenDosyalar In .SelectedItems
                ListBox1.AddItem SecilenDosyalar
            Next SecilenDosyalar
        Else
            MsgBox "Hiç Bir Dosya Seçmediniz"
        End If
    End With
    Set fd = Nothing
End Sub


Kod:
Private Sub CommandButton2_Click()
Unload Me
End Sub
Kod:
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Application.ScreenUpdating = False
Dim DB As ADODB.Connection
Dim RS As ADODB.Recordset
Dim SQLStr As String
Set DB = New ADODB.Connection
MyPath = ListBox1.Value
DB.Open "Driver={Microsoft Excel Driver (*.xls)}; DBQ=" & MyPath
Set RS = New ADODB.Recordset
RS.CursorLocation = adUseClient
RS.CursorType = adOpenDynamic
RS.LockType = adLockOptimistic
SQLStr = "SELECT * FROM [Sayfa1$]"
RS.Open SQLStr, DB, 1, 3
Range("A" & [A65536].End(3).Row + 1).CopyFromRecordset RS
DB.Close
Set DB = Nothing
Set RS = Nothing
 
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

Öncelikle yanlış yerde açtığım için özür dilerim.
Affınıza sığınıyorum.

Ellerine sağlık mükkemel bir çalışma olmuş.Çok teşekkür ederim.
Allah razı olsun.
 
Merhaba,

Tam 2 ay sonra yanıt alıyorsunuz. Bunun nedeni sorunuzu ilgili olmayan yerde sormanız.

Konu tarafımdan Makro bölümüne aktarıldı.

Sorunuzun çözümüne gelince, bir çok çözüm yolu olabilir. Ben şöyle düşündüm :

1 yada 2 dosya ile sınırlı kalmamak için birleştirilecek dosyaları seçerek tamam dediğinizde ListBoxa alıp Listboxta çift tıkladığınız dosyayı ilgili dosyaya aktarır.

Kod:
Private Sub CommandButton1_Click()
    ListBox1.Clear
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Dim SecilenDosyalar As Variant
    With fd
        .Filters.Clear
'        .Filters.Add "All files", "*.*"
        .Filters.Add "Excel Dosyaları", "*.xls; *.xls; *.xlsx", 1
        If .Show = -1 Then
            For Each SecilenDosyalar In .SelectedItems
                ListBox1.AddItem SecilenDosyalar
            Next SecilenDosyalar
        Else
            MsgBox "Hiç Bir Dosya Seçmediniz"
        End If
    End With
    Set fd = Nothing
End Sub


Kod:
Private Sub CommandButton2_Click()
Unload Me
End Sub
Kod:
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Application.ScreenUpdating = False
Dim DB As ADODB.Connection
Dim RS As ADODB.Recordset
Dim SQLStr As String
Set DB = New ADODB.Connection
MyPath = ListBox1.Value
DB.Open "Driver={Microsoft Excel Driver (*.xls)}; DBQ=" & MyPath
Set RS = New ADODB.Recordset
RS.CursorLocation = adUseClient
RS.CursorType = adOpenDynamic
RS.LockType = adLockOptimistic
SQLStr = "SELECT * FROM [Sayfa1$]"
RS.Open SQLStr, DB, 1, 3
Range("A" & [A65536].End(3).Row + 1).CopyFromRecordset RS
DB.Close
Set DB = Nothing
Set RS = Nothing
 
Application.ScreenUpdating = True
End Sub




elinize saglık çok güzel bir çalışma bu işe yarayan bir çalışma bende yaptım ama ikisi arasında daglar yollar denizler kadar fark var :)
neticede aynı işi yapıyor ama bu daha zahmetsiz ve dertsiz.
 
Bu dosyadaki sütun etiketlerini ve sütun sayısını kendimize göre uygun hale getirmemiz mümkün müdür?
 
Geri
Üst