Excel Birden Fazla Çalışma Kitabından Veri Çekmek

M

mrtank50

Altın Üye
Katılım
10 Haziran 2018
Mesajlar
35
Excel Vers. ve Dili
Excel 2021 LTSC Professional Plus 64 bit
Altın Üyelik Bitiş Tarihi
10-03-2027
Arkadaşlar merhaba günaydın.

Öncelikle istediğimin çok zor olduğunu biliyorum . Bana göre imkansız ama genede sormak istedim.

Elimde personelin 300-350 tane ayrı ayrı excel kitabı var.

Sistem toplu vermiyor malasef.

Excel'de bunu birleştirip ekte'ki yaptığım örnek şablona aktarabilir mi?
 

Ekli dosyalar

H

haliliyas

Katılım
2 Temmuz 2014
Mesajlar
223
Excel Vers. ve Dili
2021 Türkçe, 64bit
bütün dosyalarınız bu dosyayla aynı yapıda mı? (buradaki dosyayı indiremediğimden mesajdaki dosyanızla aynı yapıda olduğunu varsayıyorum)
başlıklar 3. satırda "A3:Q3" ve aynı sırada mı?
Veriler A4:Q aralığında mı?
verileri kod ile alacağımızdan, alınacak dosyanın xlsm yada xlsb gibi makro çalıştıran dosya yapısında olmasının bir sakıncası var mı?
ayrıca sayfa adları aynı mı değişken mi?
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
570
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
mrtank50' Alıntı:
Arkadaşlar merhaba günaydın.

Öncelikle istediğimin çok zor olduğunu biliyorum . Bana göre imkansız ama genede sormak istedim.

Elimde personelin 300-350 tane ayrı ayrı excel kitabı var.

Sistem toplu vermiyor malasef.

Excel'de bunu birleştirip ekte'ki yaptığım örnek şablona aktarabilir mi?
Genişletmek için tıkla ...
sizin dosyadaki isim yazılı olan dosyaların bazılarında sicil no lar farklı yerde yazılmış. Aslında iki tip dosyanız var gibi
 
M

mrtank50

Altın Üye
Katılım
10 Haziran 2018
Mesajlar
35
Excel Vers. ve Dili
Excel 2021 LTSC Professional Plus 64 bit
Altın Üyelik Bitiş Tarihi
10-03-2027
volki_112' Alıntı:
sizin dosyadaki isim yazılı olan dosyaların bazılarında sicil no lar farklı yerde yazılmış. Aslında iki tip dosyanız var gibi
Genişletmek için tıkla ...
Hocam sicil no'da önemli değil gerekirse almasın . İsim soyisim izin rapor yeterlidir bana.
 
H

haliliyas

Katılım
2 Temmuz 2014
Mesajlar
223
Excel Vers. ve Dili
2021 Türkçe, 64bit
verilerin alınacağı sayfanın adı: Veri olmalı
dosyanızın formatı : xlsm yada xlsb olmalı
veri çekeceğiniz bütün exceller Ana dosyanızla aynı dizindeki Veri adında bir klasörün içinde olmalı
Ana excel dosyanıza bir modül ekleyip aşağıdaki kodu yapıştırmalısınız
Kod: 
Option Compare Text

Sub KapaliExcel_VeriAl_hy()
'Excel Excel Bağla Referanssız ________________________________________________hy
Dim SQL As String
Dim xCon As Object
Dim xRs As Object

Set xCon = CreateObject("Adodb.Connection")
Set xRs = CreateObject("adodb.recordset")

Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
Set Syf = ThisWorkbook.Worksheets("Veri")
Syf.UsedRange.Offset(3).Clear 'sayfadaki önceki verileri temizlemek için

sonStr = Syf.Cells(Syf.Rows.Count, "B").End(xlUp).Row
xSira = Val(Syf.Cells(sonStr, 1))
     Set FSO = CreateObject("Scripting.FileSystemObject")
    With FSO
        AnaKlsr = ThisWorkbook.Path & "\" & "Veri"
        If .FolderExists(AnaKlsr) Then
            For Each f In .GetFolder(AnaKlsr).Files
              
            xAdi = ""
            xSoyadi = ""
            xSicil = ""
            xUnvan = ""
          
            x1_izinSure = ""
            x1_izinBas = ""
            x1_izinBit = ""
            x2_izinSure = ""
            x2_izinBas = ""
            x2_izinBit = ""
          
            x1_RprSure = ""
            x1_RprBas = ""
            x1_RprBit = ""
            x2_RprSure = ""
            x2_RprBas = ""
            x2_RprBit = ""
            '____________________________________________________________
                SQL = "SELECT * FROM [Sheet1$] where  F1 <> '' ;"
                xCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & f.Path & _
                                        ";extended properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""
                xCon.Open
                xRs.Open SQL, xCon, 0, 1
              
                If Not xRs.BOF And Not xRs.EOF Then
                sonStr = sonStr + 1
                xSira = xSira + 1
                xDz = xRs.getrows
                    For x = 0 To UBound(xDz, 2)
                    xVeri = WorksheetFunction.Trim(WorksheetFunction.Clean(xDz(0, x) & " " & xDz(1, x)))
                    Select Case True
                        Case xVeri Like "S?c?l*No*"
                            xSicil = Split(CStr(xVeri) & " ", " ")(2)
                  
                        Case xVeri Like "Ad*"
                            xAdi = Split(xVeri & " ", " ")(1)
                  
                        Case xVeri Like "SoyAd*"
                            xSoyadi = Split(xVeri & " ", " ")(1)
                  
                        Case xVeri Like "?nvan*"
                            xUnvan = Split(xVeri & " ", " ")(1)
                  
                        Case xVeri Like "Top.*?zin*devre*" And (x + 1 <= UBound(xDz, 2))
                        xVeri2 = ""
                        xVeri2 = CStr(WorksheetFunction.Trim(WorksheetFunction.Clean(xDz(0, x + 1))))
                            If Not (xVeri2 Like "hastal?k*?z?n*ler*") And _
                               Not (xVeri2 Like "Raporun Al?nd* Yer*") And xVeri2 <> "" Then
                                x1_izinSure = xDz(3, x + 1)
                                x1_izinBas = Replace(xDz(5, x + 1) & "", "/", ".")
                                x1_izinBit = Replace(xDz(6, x + 1) & "", "/", ".")
                            End If

                        xVeri2 = ""
                        If (x + 2 <= UBound(xDz, 2)) Then xVeri2 = WorksheetFunction.Trim(WorksheetFunction.Clean(xDz(0, x + 2)))
                            If Not (xVeri2 Like "hastal?k*?z?n*ler*") And _
                               Not (xVeri2 Like "Raporun Al?nd* Yer*") And xVeri2 <> "" Then
                                x2_izinSure = xDz(3, x + 2)
                                x2_izinBas = Replace(xDz(5, x + 2) & "", "/", ".")
                                x2_izinBit = Replace(xDz(6, x + 2) & "", "/", ".")
                            End If

                        Case xVeri Like "Raporun Al?nd* Yer*" And (x + 1 <= UBound(xDz, 2))
                         xVeri2 = ""
                         xVeri2 = CStr(WorksheetFunction.Trim(WorksheetFunction.Clean(xDz(0, x + 1))))
                            If xVeri2 <> "" Then
                                x1_RprSure = xDz(5, x + 1)
                                x1_RprBas = Replace(xDz(6, x + 1) & "", "/", ".")
                                x1_RprBit = Replace(xDz(7, x + 1) & "", "/", ".")
                            End If
                        xVeri2 = ""
                        If (x + 2 <= UBound(xDz, 2)) Then xVeri2 = WorksheetFunction.Trim(WorksheetFunction.Clean(xDz(0, x + 2)))
                            If xVeri2 <> "" Then
                                x2_RprSure = xDz(5, x + 2)
                                x2_RprBas = Replace(xDz(6, x + 2) & "", "/", ".")
                                x2_RprBit = Replace(xDz(7, x + 2) & "", "/", ".")
                            End If
                    End Select
                    Next x
                    Syf.Cells(sonStr, 1) = xSira
                    Syf.Cells(sonStr, 2) = xAdi
                    Syf.Cells(sonStr, 3) = xSoyadi
                    Syf.Cells(sonStr, 4) = xSicil
                    Syf.Cells(sonStr, 5) = xUnvan
                  
                    Syf.Cells(sonStr, 6) = x1_izinSure
                    Syf.Cells(sonStr, 7) = x1_izinBas
                    Syf.Cells(sonStr, 8) = x1_izinBit
                    Syf.Cells(sonStr, 9) = x2_izinSure
                    Syf.Cells(sonStr, 10) = x2_izinBas
                    Syf.Cells(sonStr, 11) = x2_izinBit
                  
                    Syf.Cells(sonStr, 12) = x1_RprSure
                    Syf.Cells(sonStr, 13) = x1_RprBas
                    Syf.Cells(sonStr, 14) = x1_RprBit
                    Syf.Cells(sonStr, 15) = x2_RprSure
                    Syf.Cells(sonStr, 16) = x2_RprBas
                    Syf.Cells(sonStr, 17) = x2_RprBit
                End If
            xRs.Close
            xCon.Close
          
            Next f
        End If
    End With
Set xRs = Nothing
Set xCon = Nothing
'Excel Excel Bağla Referanssız ________________________________________________BİTTİ
End Sub
dosya bağlantısı:

TopluExcel_hy.rar

drive.google.com drive.google.com
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst