RE: Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme - feraz - 22/04/2021
Alttaki kod çalışırsa daha iyi bende çalışıyor.Yani 65536 satır sonrası için öncekinde sorun olabilir onun için bu kodu yazdım.
Private Sub CommandButton1_Click()
Dim rs As Object, con As Object
Dim son As Long, alan As String, baslik As Range
Set rs = CreateObject("ADODB.Recordset")
Set con = CreateObject("ADODB.Connection")
Dim yol As String, yol2 As String
yol = ThisWorkbook.Path & Application.PathSeparator
yol2 = Dir(yol & "*xlsx")
With ThisWorkbook.Sheets("TümVeri")
For Each baslik In .Range("B1:Q1")
alan = alan & "[" & baslik.Value & "]" & ","
Next
alan = Mid(alan, 1, Len(alan) - 1)
.Range("A2:Q" & Rows.Count).Clear
Do Until yol2 = ""
son = .Range("B" & Rows.Count).End(3).Row + 1
con.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & yol2 & ";extended properties=""Excel 12.0;hdr=yes"""
rs.Open "select " & alan & " from [MEMURLAR$]", con, 1, 1
.Range("B" & son).CopyFromRecordset rs
rs.Close
con.Close
Sql = vbNullString
yol2 = Dir
Loop
End With
Set rs = Nothing
Set con = Nothing: Set baslik = Nothing
MsgBox "Bitti", vbInformation, "Bilgi"
End Sub
RE: Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme - feraz - 22/04/2021
Ayrıca a sütunu seri numaralansın isterseniz alttaki kodu ekleyin.
If WorksheetFunction.CountA(.Range("B2:B" & Rows.Count)) > 0 Then
son = .Range("B" & Rows.Count).End(3).Row
.Range("A2").Value = 1
.Range("A2:A" & son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Stop:=son
End If
RE: Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme - feraz - 22/04/2021
(22/04/2021, 11:57)feraz yazdı: .Range("A" & son & ":A" & Rows.Count).Clear Ya 10.mesajdaki yukardaki kodu alttaki gibi yapınki A sütunu silinsin.O kodun yukarısındaki son= ile olan stırda silinebilir.
Bir konuya daha bir sürü mesaj yazdım
.Range("A2:A" & Rows.Count).Clear
RE: Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme - berduş - 22/04/2021
bu da @feraz hocamınkinden biraz farklı bir yöntem, sadece arşivde bulunsun istedim, ama verileri alırken türü metinmiş gibi alıyor, yeşil üçgenler kaplıyor ortalığı)
Sub VeriAl()
Dim con As ADODB.Connection
Set con = New ADODB.Connection
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes;"""
yol = ThisWorkbook.Path & Application.PathSeparator
yol2 = Dir(yol & "*xlsx")
txtAlan = "[0], [SİCİL], [Rütbesi], [KODU], [Adı SOYADI], [TELEFON], [BİRİM], [CİNSİYET], [DİĞER], [PAZARTESİ], [SALI], [ÇARŞAMBA], [PERŞEMBE], [CUMA], [CUMARTESİ], [PAZAR], [AÇIKLAMA]"
With ThisWorkbook.Sheets("TümVeri")
.Range("A2:Q" & Rows.Count).Clear
Do Until yol2 = ""
txtSql = "INSERT INTO [TümVeri$] (" & txtAlan & ") " & _
"SELECT " & txtAlan & " " & _
"FROM [MEMURLAR$] IN '" & yol & yol2 & "'[EXCEL 8.0;] " & _
"where ([SİCİL] Is Not Null);"
con.Execute txtSql
yol2 = Dir
Loop
End With
con.Close: Set con = Nothing
MsgBox "Bitti", vbInformation, "Bilgi"
End Sub
RE: Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme - yyhy - 23/04/2021
Sayın feraz bey macroyu birleştirmeye çalışıyordum. Son macroyu uygularsam tamam olurmu acaba bir onu deneyeyim
RE: Klasör İçerisindeki Excel Dosyalarını Tek Dosyada Birleştirme - berduş - 23/04/2021
yada alanları kullanmadan
Sub VeriAl_alansiz()
Dim con As ADODB.Connection
Set con = New ADODB.Connection
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes;"""
yol = ThisWorkbook.Path & Application.PathSeparator
yol2 = Dir(yol & "*xlsx")
With ThisWorkbook.Sheets("TümVeri")
.Range("A2:Q" & Rows.Count).Clear
Do Until yol2 = ""
txtSql = "INSERT INTO [TümVeri$] " & _
"SELECT * " & _
"FROM [MEMURLAR$] IN '" & yol & yol2 & "'[EXCEL 8.0;] " & _
"where ([SİCİL] Is Not Null);"
con.Execute txtSql
yol2 = Dir
Loop
End With
con.Close: Set con = Nothing
MsgBox "Bitti", vbInformation, "Bilgi"
End Sub
|