Dim con As ADODB.Connection
Set con = New ADODB.Connection
eğer referanssız kullanmak isterseniz yukardaki 2 satırı silip aşağıdaki satırı ekleyebilirsiniz.
Set con = CreateObject("adodb.connection")
kodunu kullanmayı deneyebilirsiniz
sıra numarası derken kast ettiğiniz tam olarak ne?
@
feraz beyin önerdiği
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
kodunu kullandınız mı?
kodu aşağıdaki gibi düzenleyip dener misiniz?
Not: Referansa gerek yok
sıralama için æferaz hocamın kodu kullanılmıştır
Set con = CreateObject("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
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
End With
con.Close: Set con = Nothing
MsgBox "Bitti", vbInformation, "Bilgi"
Verileri 00 -Tüm Veri bu kitaba getirirken 00 -Tüm Veri bu kitapta a2 den itibaren aşağıya doğru sıra numarası vermek istiyorum.
Ayrıca son kodu da çalıştıramadım. Örnek dosya ekleyebilir misiniz?
Son mesajı uyguladım ama hücrelerde mavi tik kalıyor. Dosyayı da ekliyorum.
referans eklenmiş ve sıralanmış haliyle dosya eklenmiştir
okla gösterilen alanlar ekleme süresini görmek içindir, silinebilirler
Private Sub CommandButton1_Click()
t1 = Now'<--Silinebilir
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
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
'Alan dönüşüm_______________________________________
.Range("B2:B" & son).NumberFormat = "0"
.Range("B2:B" & son).Value = .Range("B2:B" & son).Value
.Range("D2
" & son).NumberFormat = "0"
.Range("D2" & son).Value = .Range("D2" & son).Value
.Range("F2" & son).NumberFormat = "0"
.Range("F2:F" & son).Value = .Range("F2:F" & son).Value
'_________________________________________________
End With
con.Close: Set con = Nothing
t2 = Now'<--Silinebilir
Debug.Print "Tur", t1, t2, DateDiff("s", t1, t2)'<--Silinebilir
MsgBox "Bitti", vbInformation, "Bilgi"
End Sub
(23/04/2021, 00:11)yyhy yazdı: [ -> ]Sayın farez bey acaba sizde çalışan 00 -Tüm Veri dosyayı buraya ekyebilirmisiniz? Sayın @berduş beyin attığı kodu da çalıştıramadım.
Tüm dosyaları ekledim abey.A sütununda veriolmasın derseniz alttaki kodları silin.
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
@
berduş hocam sanki bir ara bu insert into için çok fazla veri içn bilgisayarı kilitliyor çok uzun çalışıyor diye demiştiniz yanılmıyorsam
