Soru Farklı excel dosyalarından verileri çekip sayfalara yazma

[serhank20]

Merhaba üstadlarim,
Çok arayıp çözümünü bulamadığım bi konuda yardımcı olmanızı isteyeceğim.

Ahmet, Mehmet, Zeynep, Burcu isimli kapalı ecxel dosyalarım var. Bu dosyalardaki A1:E20 arasındaki verileri çekip, Deneme isimli excel dosyasındaki Ahmet, Mehmet, Zeynep, Burcu isimli sayfaların A1:E20 arasına makro koduyla yazdırmak istiyorum. Hücreler boşsa boş kalsın istiyorum. Nasıl yapabilirim? Yardımcı olursanız çok sevinirim.

 

[serhank20]

Excel konusunda uzman arkadaşlar yardımlarınızi bekliyorum

 

[Korhan Ayhan]

Kapalı excel dosyalarındaki veri alınacak sayfanın ismi nedir?

 

[serhank20]

Kapalı excel dosyalarındaki veri alınacak sayfanın ismi nedir?

Sayfa1

 

[Korhan Ayhan]

Dosyalarınızın uzantısı nedir? (xlsx - xlsm)

 

[serhank20]

Dosyalarınızın uzantısı nedir? (xlsx - xlsm)

Hocam kapalı dosyaların uzantısı xlsx
Deneme dosyasının uzantısı xlsm

 

[Korhan Ayhan]

Bütün dosyalarınız aynı klasör altında olduğunu varsaydım.

Option Explicit

Sub Veri_Al()
    Dim Baglanti As Object, Kayit_Seti As Object, Yol As String, Sutun As Byte
    Dim Dosya As String, Sayfa As String, Baslik As Object, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Yol = ThisWorkbook.Path & "\"
    
    Dosya = Dir(Yol & "*.xlsx")
    
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Yol & Dosya & _
            ";Extended Properties=""Excel 12.0;Hdr=Yes"""
            
            Kayit_Seti.Open "Select * From [Sayfa1$A1:E20]", Baglanti, 1, 3
            
            Sayfa = CStr(Replace(Dosya, "." & CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya), ""))
            
            With Sheets(Sayfa)
                .Range("A:E").Clear
                .Range("A1:E1").Font.Bold = True
                Sutun = 0
                If Kayit_Seti.RecordCount > 0 Then
                    .Range("A2").CopyFromRecordset Kayit_Seti
                    For Each Baslik In Kayit_Seti.Fields
                        Sutun = Sutun + 1
                        .Cells(1, Sutun) = Baslik.Name
                    Next
                    .Columns.AutoFit
                End If
            End With
        End If
        Kayit_Seti.Close
        Baglanti.Close
        Dosya = Dir
    Wend
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[serhank20]

Korhan hocam başarılı bir şekilde çekti ama 1. satırlarda hata var. Örneğin,

Ahmet'i

A

A1

C

C1

C2

Mehmet'i

C

A

C1

Sayfa1$A1:E20.D

Sayfa1$A1:E20.D

şeklinde çekti.

 

[Korhan Ayhan]

Örnek dosya paylaşınız.

Paylaşım sitelerine yükleyip link verebilirsiniz.

 

[serhank20]

Örnek dosya paylaşınız.

Paylaşım sitelerine yükleyip link verebilirsiniz.

deneme.xlsm - 28 KB

 

[Korhan Ayhan]

Veri dosyasını kast etmiştim.

 

[serhank20]

Veri dosyasını kast etmiştim.

Mehmet.xlsx - 9 KB
Mehmet dosyası

 

[Korhan Ayhan]

Bu şekilde deneyiniz.

Option Explicit

Sub Veri_Al()
    Dim Baglanti As Object, Kayit_Seti As Object, Yol As String
    Dim Dosya As String, Sayfa As String, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Yol = ThisWorkbook.Path & "\"
    
    Dosya = Dir(Yol & "*.xlsx")
    
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Yol & Dosya & _
            ";Extended Properties=""Excel 12.0;Hdr=No"""
            
            Kayit_Seti.Open "Select * From [Sayfa1$A1:E20]", Baglanti, 1, 3
            
            Sayfa = CStr(Replace(Dosya, "." & CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya), ""))
            
            With Sheets(Sayfa)
                .Range("A:E").Clear
                If Kayit_Seti.RecordCount > 0 Then
                    .Range("A1").CopyFromRecordset Kayit_Seti
                    .Columns.AutoFit
                End If
            End With
        End If
        Kayit_Seti.Close
        Baglanti.Close
        Dosya = Dir
    Wend
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[serhank20]

Korhan hocam çok teşekkür ediyorum. Şimdi oldu. Elinize, emeğinize sağlık. Kapalı dosyaları ana klasör içinde farklı bir klasöre taşımak istesem nereyi değiştirmem gerekiyor?

 

[Korhan Ayhan]

Bu bölümü değiştirmelisiniz.

Yol = ThisWorkbook.Path & "\"

 

[serhank20]

Korhan hocam bu formülü kendi sistemime uyarlamaya çalışıyorum. A1:E20 değilde rakamları B7:G26 şeklinde değiştirmek istesem yazdığınız formülde nereleri değiştirmem gerekiyor? Ben değiştirmeye çalıştım hata verdi.

 

[Korhan Ayhan]

Kod içinde bu adres zaten tek yerde geçiyor.

Hata durumunu bilemiyorum. Hata veren dosyalarınızı paylaşma durumunuz varsa inceleyebiliriz.

 

[serhank20]

Kod içinde bu adres zaten tek yerde geçiyor.

Hata durumunu bilemiyorum. Hata veren dosyalarınızı paylaşma durumunuz varsa inceleyebiliriz.

Adreste bir sıkıntı yokmuş hocam. Dosya ve sayfa isimleri değiştiğinde nereleri değiştirmem gerekiyor?

 

[Korhan Ayhan]

Dosya adı değişmesi önemli değil. Ama sayfa adı önemli. Onu da aşağıdaki satırdan değiştirmelisiniz.

Kayit_Seti.Open "Select * From [Sayfa1$A1:E20]", Baglanti, 1, 3

 

[serhank20]

ogrenci1.xlsx - 12 KB

Hocam dosya bu. Bunun B7:G26 daki verileri çekmek istiyorum