RE: Birden Fazla Excel Sayfasını Tek Bir Excel Sayfasında Birleştirme - berduş - 09/12/2021
çalışmanız Excel üzerinden olmayacak mı?
aşağıdaki çalışmayı inceler misiniz?
1 - tüm dosyalar aynı klasörde olmalı
2 - referanslardan Microsoft ActiveX Data Object x.x library eklenmeli
3 - 4. hakedis dosyanızda fazladan bir DTR TARİHİ sütunu vardı o sütun silindi
4 - dosyanız macro çalıştıran formata çevrildi xlsm
Verileri alma fonksiyonu
Option Compare Text' sayfanın en başına küçük/büyük harf farkı olmasın diye
Sub VeriAl()
Dim Sql As String
Dim ADO_CN As ADODB.Connection
xSQL = dosyaAdi_FSO
Set ADO_CN = New ADODB.Connection
ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
";extended properties=""excel 12.0 Xml;hdr=Yes"""
ADO_CN.Open
SQL = "SELECT Uni.Plk, Count(Uni.Plk) AS SayF1, Sum(Uni.Tplm) AS ToplaF6 " & _
"FROM (" & xSQL & ") as Uni " & _
"GROUP BY Uni.Plk;"
Set ADO_RS = ADO_CN.Execute(SQL) ' güncelleme yapabilmek için 1,3 0lmalı yada adOpenKeyset, adLockOptimistic
' Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
GoTo son
End If
Sheets("sayfa1").Range("B2").CopyFromRecordset ADO_RS
son:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
End Sub
klasördeki tüm Excel dosyalarını alma
Function dosyaAdi_FSO() As String
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
AnaKlsr = ThisWorkbook.Path & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
If .FolderExists(AnaKlsr) Then
For Each f In .GetFolder(AnaKlsr).Files
If f.Name <> ThisWorkbook.Name And Left(f.Name, 1) <> "~" And f.Type Like "*excel*" Then 'Debug.Print say, f.Name, SyfAdiAl(f.Path)
SqlDsy = SqlDsy & SyfAdiAl(f.Path)
End If
Next f
End If
End With
dosyaAdi_FSO = Mid(SqlDsy, 10)
End Function
exceldeki ilk sayfayı alma ve Sql kodu oluşturma
Function SyfAdiAl(fn As String) As String 'fn tam yol + ad
Dim conn As Object, db As Object
Dim tbl As Object
Set conn = CreateObject("DAO.DBEngine.120")
Set db = conn.OpenDatabase(fn, False, True, "Excel 12.0 Xml;HDR=Yes;")
Set tbl = db.TableDefs(0) ' 0 is Sheets(1) : 1 is Sheets(2)
SyfAdiAl = CStr(Replace(tbl.Name, "'", "")) ' sadece ilk sayfa tblAdi = CStr(Replace(tbl.Name, "'", ""))
SyfAdiAl = "Union all " & _
"SELECT [" & tbl.Fields(1).Name & "] as Plk,[" & tbl.Fields(5).Name & "] as Tplm " & _
"FROM [" & SyfAdiAl & "B:F] IN """ & fn & """ ""EXCEL 12.0 xml;"" "
Set db = Nothing
Set conn = Nothing
End Function
RE: Birden Fazla Excel Sayfasını Tek Bir Excel Sayfasında Birleştirme - lemoncher2 - 09/12/2021
Örneği tekrar indirip denermisiniz.
RE: Birden Fazla Excel Sayfasını Tek Bir Excel Sayfasında Birleştirme - berduş - 09/12/2021
sadeleştirilip sıra no eklenmiş kod
Option Compare Text
Sub VeriAl()
Dim Sql As String
Dim ADO_CN As ADODB.Connection
xSQL = dosyaAdi_FSO
Set ADO_CN = New ADODB.Connection
ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
";extended properties=""excel 12.0 Xml;hdr=Yes"""
ADO_CN.Open
SQL = "SELECT Uni.Plk, Count(Uni.Plk) AS SayF1, Sum(Uni.Tplm) AS ToplaF6 " & _
"FROM (" & xSQL & ") as Uni " & _
"GROUP BY Uni.Plk;"
Set ADO_RS = ADO_CN.Execute(SQL) ' güncelleme yapabilmek için 1,3 0lmalı yada adOpenKeyset, adLockOptimistic
' Eğer Hiç Kayıt Yoksa
If ADO_RS.RecordCount = 0 Then
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
GoTo son
End If
Set Syf = Sheets("sayfa1")
Syf.Range("B2").CopyFromRecordset ADO_RS
SonStr = Syf.Cells(Syf.Rows.Count, "B").End(xlUp).Row - 1
With Syf.Range("a2")
.Value = 1
.AutoFill .Resize(SonStr, 1), xlFillSeries
End With
son:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
End Sub
Function dosyaAdi_FSO() As String
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
AnaKlsr = ThisWorkbook.Path & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
If .FolderExists(AnaKlsr) Then
For Each f In .GetFolder(AnaKlsr).Files
If f.Name <> ThisWorkbook.Name And Left(f.Name, 1) <> "~" And f.Type Like "*excel*" Then 'Debug.Print say, f.Name, SyfAdiAl(f.Path)
SqlDsy = SqlDsy & SyfAdiAl(f.Path)
End If
Next f
End If
End With
dosyaAdi_FSO = Mid(SqlDsy, 10)
End Function
Function SyfAdiAl(fn As String) As String 'fn tam yol + ad
Dim conn As Object, db As Object
Dim tbl As Object
Set conn = CreateObject("DAO.DBEngine.120")
Set db = conn.OpenDatabase(fn, False, True, "Excel 12.0 Xml;HDR=Yes;")
Set tbl = db.TableDefs(0) ' 0 is Sheets(1) : 1 is Sheets(2)
SyfAdiAl = CStr(Replace(tbl.Name, "'", "")) ' sadece ilk sayfa tblAdi = CStr(Replace(tbl.Name, "'", ""))
SyfAdiAl = "Union all " & _
"SELECT [Plaka] as Plk,[TOPLAM TUTAR] as Tplm " & _
"FROM [" & SyfAdiAl & "] IN """ & fn & """ ""EXCEL 12.0 xml;"" "
Set db = Nothing
Set conn = Nothing
End Function
RE: Birden Fazla Excel Sayfasını Tek Bir Excel Sayfasında Birleştirme - cdenktas - 10/12/2021
Çok teşekkür ederim. 50 adet hakediş yapıştırdım. İlk önce 32 yapıştırdığımda hata vermedi en son 18 daha yapıştırıcında hata verdi....
RE: Birden Fazla Excel Sayfasını Tek Bir Excel Sayfasında Birleştirme - berduş - 10/12/2021
sorun ya eklenen dosyalardan kaynaklanıyordu yada dosya sayısı fazla olduğundan Sql kodu çok uzamıştır o nedenle oluyordur.
sorun vermeyen bir dosyanın 50 kopyasını alıp dener misiniz? aynı işlemi uygun zamanda ben de deneyeceğim.
eğer sorun Sql kodunu uzunluğundan kaynaklanıyorsa ilgili verileri önce geçici bir sayfa aktarıp oradan alınması sağlanabilir
RE: Birden Fazla Excel Sayfasını Tek Bir Excel Sayfasında Birleştirme - berduş - 10/12/2021
uyarı mesajı olarak ne diyor?
|