• DİKKAT

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

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

S

serhank20

Katılım
13 Nisan 2020
Mesajlar
25
Excel Vers. ve Dili
excel 2010 türkçe
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.
 
Excel konusunda uzman arkadaşlar yardımlarınızi bekliyorum
 
Kapalı excel dosyalarındaki veri alınacak sayfanın ismi nedir?
 
Dosyalarınızın uzantısı nedir? (xlsx - xlsm)
 
Bütün dosyalarınız aynı klasör altında olduğunu varsaydım.

C++: 
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
 
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.
 
Örnek dosya paylaşınız.

Paylaşım sitelerine yükleyip link verebilirsiniz.
 
Veri dosyasını kast etmiştim.
 
Bu şekilde deneyiniz.

C++: 
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
 
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?
 
Bu bölümü değiştirmelisiniz.

Yol = ThisWorkbook.Path & "\"
 
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.
 
Kod içinde bu adres zaten tek yerde geçiyor.

Hata durumunu bilemiyorum. Hata veren dosyalarınızı paylaşma durumunuz varsa inceleyebiliriz.
 
Dosya adı değişmesi önemli değil. Ama sayfa adı önemli. Onu da aşağıdaki satırdan değiştirmelisiniz.

C++: 
Kayit_Seti.Open "Select * From [Sayfa1$A1:E20]", Baglanti, 1, 3
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst