Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme - MTARKALI - 13/11/2020
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.
RE: Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme - berduş - 13/11/2020
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?
RE: Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme - berduş - 13/11/2020
ayrıca
vaFiles (i)= ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name yerine
vaFiles (i) = ThisWorkbook.FullName de yazılabilir
Re: Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme - feraz - 13/11/2020
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
RE: Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme - berduş - 13/11/2020
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
RE: Birden Çok Çalışma Kitabından Verileri Tek Dosyada Birleştirme - MTARKALI - 13/11/2020
(13/11/2020, 21:37)feraz yazdı:
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.
|