Skip to main content

AccessTr.neT


Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme

Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme

Çözüldü #1
Merhabalar Arkadaşlar
Kurumlardan sürekli olarak farklı toblolar ile veri topluyorum ve hepsini tek bir tabloda birleştiriyorum
Benim veri topladığım ana dosyam sürece göre değişebiliyor
1.satırda konu başlığı, 2. satırda da istenilen veri türü başlıkları yer alıyor
bu kodu buldum düzenledim ama ya hata veriyor ya da
1.satırdaki verileri doğrulayarak, 2.satırdan yazmaya başlıyor
bunu;
2.satırdaki verileri doğrulayarak (sürece göre bazen 1.satırdan bazen de 4.satırdan olabiliyor)
3.satırdan yazmaya başlaması gerekiyor.


işin içinden çıkamadım bi yardım lütfen


Kod:
Sub ImportDataFromMultipleWorkbooks()

Dim vaFiles As Variant
Dim wbkToCopy As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Sayın " & Environ("UserName")

ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    ws.Range("A2:K" & Rows.Count).Clear
   
    lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
   
   
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
    Title:="Select Files to Proceed", MultiSelect:=True)
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
   
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If
           
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
           
            Set wsa = ActiveWorkbook.ActiveSheet
           
            lra = wsa.Cells(Rows.Count, 1).End(xlUp).Row
            lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column
           
            For c = 1 To lc
                For ca = 1 To lrc
                    If wsa.Cells(1, ca) = ws.Cells(1, c) Then
                        cn = ca
                        Exit For
                    End If
                Next ca
                For r = 2 To lra
                    y = ws.Cells(Rows.Count, c).End(xlUp).Offset(1, 0).Row
                    If c <> lc Then
                        ws.Cells(y, c) = wsa.Cells(r, cn)
                    Else
                        ws.Cells(y, c) = "FileName: " & Mid(ActiveWorkbook.Name, 1, InStr(1, _
                        ActiveWorkbook.Name, ".xls") - 1)
                    End If
                    y = y + 1
                Next r
            Next c
            wbkToCopy.Close savechanges:=False
skipfile:
        Next i
        ws.Range("A2:K2").EntireColumn.AutoFit
        ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
    Else
        ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
    End If
Else
    ms2 = MsgBox("Başarısız!", vbInformation, un)
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

Bu resimdeki örnek tabloda 1. satırı silersem verilerim doğru geliyor.
Ama böyece ya da kodda düzeltme yapınca hata veriyor.

[Resim: x2x7eM.jpg]
.rar PROJE_22.rar (Dosya Boyutu: 34,68 KB | İndirme Sayısı: 2)
Cevapla
#2
maalesef resim eklenmemiş
sorunuzu tam olarak anlamadım, biraz daha açıklayabilir misiniz?
mesela ana dosyayı açtınız daha önce veri girilmiş 7 satır var kod ne yapacak?
daha önce veri girilmişse, bu eski veriler silinecek mi yoksa yeni veriler eski verilere mi eklenecek?

    ws.Range("A2:K" & Rows.Count).Clear kodunu:
    ws.Range("A3:K" & Rows.Count).Clear

lrc = wsa.Cells(1, Columns.Count).End(xlToLeft).Column kodunu:
lrc = wsa.Cells(2, Columns.Count).End(xlToLeft).Column

değiştirip dener misiniz?
Cevapla
#3
ayrıca
vaFiles (i)= ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name yerine
vaFiles (i) = ThisWorkbook.FullName de yazılabilir
Cevapla
#4
[Resim: 14538ca1d206c6f7d1b3.gif]

Sub ImportDataFromMultipleWorkbooks()

    Dim vaFiles As Variant
    Dim wbkToCopy As Workbook
    Dim ws As Worksheet
    Dim wsa As Worksheet
    Const sonSutunNo As Byte = 9
    Const ilBosksatirNo As Byte = 3
    Dim bulSatirNo As Range, bulSutunNo As Range
    Dim i As Long, son As Long, k As Byte
   
    ThisWorkbook.Activate
   
    Set ws = ThisWorkbook.Sheets("Sayfa1")
   
    un = "Sayýn " & Environ("UserName")
   
    ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
    If ms1 = vbYes Then
        ws.Range(ws.Cells(ilBosksatirNo, 1), ws.Cells(Rows.Count, sonSutunNo)).ClearContents
        ws.Range(ws.Cells(ilBosksatirNo, 1), ws.Cells(Rows.Count, sonSutunNo)).Borders.LineStyle = xlNone
        ChDir (ThisWorkbook.Path)
        vaFiles = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
        Title:="Select Files to Proceed", MultiSelect:=True)
       
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = False
        End With
       
        If IsArray(vaFiles) Then
            For i = LBound(vaFiles) To UBound(vaFiles)
                If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                    ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                    GoTo skipfile:
                End If
               
                Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
                Set wsa = ActiveWorkbook.ActiveSheet
                Set bulSatirNo = wsa.Range("A:A").Find(ws.Range("A2").Value, , , 1)
                Set bulSutunNo = wsa.Rows(2).Find(ws.Range("i2").Value, , , 1)
               
                If Not bulSatirNo Is Nothing And Not bulSutunNo Is Nothing Then
                    son = wsa.Cells(Rows.Count, 2).End(3).Row
                    If son >= bulSatirNo.Row Then
                        wsa.Range(wsa.Cells(bulSatirNo.Row + 1, 1), wsa.Cells(son, bulSutunNo.Column)).Copy
                        ws.Range("A" & Rows.Count).End(3)(2, 1).PasteSpecial xlPasteValuesAndNumberFormats
                    End If
                End If
                Set bulSatirNo = Nothing
                Set bulSutunNo = Nothing
                wbkToCopy.Close savechanges:=False
skipfile:
            Next i
            ws.Range("A:K").EntireColumn.AutoFit
            ms5 = MsgBox("Verileriniz ana dosyaya aktarýlmýþtýr", vbInformation, un)
        Else
            ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
        End If
    Else
        ms2 = MsgBox("Baþarýsýz!", vbInformation, un)
    End If
    If WorksheetFunction.CountA(ws.Range("A2:A" & Rows.Count)) > 0 Then
        son = ws.Range("A" & Rows.Count).End(3).Row
        ws.Range(ws.Cells(ilBosksatirNo, 1), ws.Cells(son, sonSutunNo)).Borders.LineStyle = 1
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub
.rar PROJE_22.rar (Dosya Boyutu: 35,98 KB | İndirme Sayısı: 2)
Cevapla
#5
bu da Recordsetli yöntem
Not: 'Önce referanslardan Microsoft ActiveX Data Objects x.x  library eklenmeli
'x.x yerine bilgisayardaki sürüm olmalı
'Microsoft ActiveX Data Objects 2.0 Library
'Microsoft ActiveX Data Objects 2.8 Library
'Microsoft ActiveX Data Objects 6.0 Library  gibi
Sub ImportDataFromMultipleWorkbooks()

Dim vaFiles As Variant
Dim ws As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Sayın " & Environ("UserName")

ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    ws.Range("A3:K" & Rows.Count).Clear
   
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
    Title:="Select Files to Proceed", MultiSelect:=True)
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
   
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
                   
            If vaFiles(i) = ThisWorkbook.FullName Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If

'hy Recordset___________________________
Dim Sql As String
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection
   
sonStr = ws.Range("A" & Rows.Count).End(3).Row + 1
SQL = "SELECT * " & _
      "FROM [Sayfa1$A3:I] " & _
      "where [F2]  Is Not Null"

Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection

ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & vaFiles(i) & _
                          ";extended properties=""excel 12.0;hdr=no"""
ADO_CN.Open
ADO_RS.Open SQL, ADO_CN, 3, 1
'
'  Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
    GoTo skipfile:
End If
ADO_RS.MoveLast
ADO_RS.MoveFirst

ws.Range("A" & sonStr).CopyFromRecordset ADO_RS 'excelde

skipfile:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
'_______________________________________

Next i
        ws.Range("A2:K2").EntireColumn.AutoFit
        ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
    Else
        ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
    End If
Else
    ms2 = MsgBox("Başarısız!", vbInformation, un)
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub
.rar TOPLAM_Recordset_hy.rar (Dosya Boyutu: 18,96 KB | İndirme Sayısı: 6)
Cevapla
#6
(13/11/2020, 21:37)feraz yazdı: [Resim: 14538ca1d206c6f7d1b3.gif]

Sub ImportDataFromMultipleWorkbooks()

    Dim vaFiles As Variant
    Dim wbkToCopy As Workbook
    Dim ws As Worksheet
    Dim wsa As Worksheet
    Const sonSutunNo As Byte = 9
    Const ilBosksatirNo As Byte = 3
    Dim bulSatirNo As Range, bulSutunNo As Range
    Dim i As Long, son As Long, k As Byte
   
    ThisWorkbook.Activate
   
    Set ws = ThisWorkbook.Sheets("Sayfa1")
   
    un = "Sayýn " & Environ("UserName")
   
    ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
    If ms1 = vbYes Then
        ws.Range(ws.Cells(ilBosksatirNo, 1), ws.Cells(Rows.Count, sonSutunNo)).ClearContents
        ws.Range(ws.Cells(ilBosksatirNo, 1), ws.Cells(Rows.Count, sonSutunNo)).Borders.LineStyle = xlNone
        ChDir (ThisWorkbook.Path)
        vaFiles = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
        Title:="Select Files to Proceed", MultiSelect:=True)
       
        With Application
            .DisplayAlerts = False
            .ScreenUpdating = False
        End With
       
        If IsArray(vaFiles) Then
            For i = LBound(vaFiles) To UBound(vaFiles)
                If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                    ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                    GoTo skipfile:
                End If
               
                Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
                Set wsa = ActiveWorkbook.ActiveSheet
                Set bulSatirNo = wsa.Range("A:A").Find(ws.Range("A2").Value, , , 1)
                Set bulSutunNo = wsa.Rows(2).Find(ws.Range("i2").Value, , , 1)
               
                If Not bulSatirNo Is Nothing And Not bulSutunNo Is Nothing Then
                    son = wsa.Cells(Rows.Count, 2).End(3).Row
                    If son >= bulSatirNo.Row Then
                        wsa.Range(wsa.Cells(bulSatirNo.Row + 1, 1), wsa.Cells(son, bulSutunNo.Column)).Copy
                        ws.Range("A" & Rows.Count).End(3)(2, 1).PasteSpecial xlPasteValuesAndNumberFormats
                    End If
                End If
                Set bulSatirNo = Nothing
                Set bulSutunNo = Nothing
                wbkToCopy.Close savechanges:=False
skipfile:
            Next i
            ws.Range("A:K").EntireColumn.AutoFit
            ms5 = MsgBox("Verileriniz ana dosyaya aktarýlmýþtýr", vbInformation, un)
        Else
            ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
        End If
    Else
        ms2 = MsgBox("Baþarýsýz!", vbInformation, un)
    End If
    If WorksheetFunction.CountA(ws.Range("A2:A" & Rows.Count)) > 0 Then
        son = ws.Range("A" & Rows.Count).End(3).Row
        ws.Range(ws.Cells(ilBosksatirNo, 1), ws.Cells(son, sonSutunNo)).Borders.LineStyle = 1
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub
Aynen buydu aradığım. Makro bilgim yok ama kodları takip edip mantığını görebiliyorum. Çok teşekkür ederim.
(13/11/2020, 22:37)berduş yazdı: bu da Recordsetli yöntem
Not: 'Önce referanslardan Microsoft ActiveX Data Objects x.x  library eklenmeli
'x.x yerine bilgisayardaki sürüm olmalı
'Microsoft ActiveX Data Objects 2.0 Library
'Microsoft ActiveX Data Objects 2.8 Library
'Microsoft ActiveX Data Objects 6.0 Library  gibi
Sub ImportDataFromMultipleWorkbooks()

Dim vaFiles As Variant
Dim ws As Worksheet

ThisWorkbook.Activate

Set ws = Sayfa1

un = "Sayın " & Environ("UserName")

ms1 = MsgBox("Birden fazla dosyadan veri almak istiyor musunuz?", vbInformation + vbYesNo, un)
If ms1 = vbYes Then
    ws.Range("A3:K" & Rows.Count).Clear
   
    vaFiles = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", _
    Title:="Select Files to Proceed", MultiSelect:=True)
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
   
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
                   
            If vaFiles(i) = ThisWorkbook.FullName Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If

'hy Recordset___________________________
Dim Sql As String
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection
   
sonStr = ws.Range("A" & Rows.Count).End(3).Row + 1
SQL = "SELECT * " & _
      "FROM [Sayfa1$A3:I] " & _
      "where [F2]  Is Not Null"

Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection

ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & vaFiles(i) & _
                          ";extended properties=""excel 12.0;hdr=no"""
ADO_CN.Open
ADO_RS.Open SQL, ADO_CN, 3, 1
'
'  Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
    GoTo skipfile:
End If
ADO_RS.MoveLast
ADO_RS.MoveFirst

ws.Range("A" & sonStr).CopyFromRecordset ADO_RS 'excelde

skipfile:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
'_______________________________________

Next i
        ws.Range("A2:K2").EntireColumn.AutoFit
        ms5 = MsgBox("Verileriniz ana dosyaya aktarılmıştır", vbInformation, un)
    Else
        ms3 = MsgBox("Dosya seçmediniz!", vbExclamation, un)
    End If
Else
    ms2 = MsgBox("Başarısız!", vbInformation, un)
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub
Yukarıdaki yöntem şuan ki işime daha uygun ama bunuda inceleyeceğim. Sürekli ihtiyacım olacak bu tarz kodlara. Tekrar teşekkürler.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da