Hücreleri otomatik kopyalama yapıştırma

[Orion1]

Bunuda ado kullanarak yaptım.
Diğer yönteme göre daha hızlı çalışıyor.
Dosya ektadir.
Bütün dosyaların ayni klasörde olamsı lazımdır.

Sub ADO_ile_kapali_A_Dosyasından_B_dosyasina_Kayit()
Dim i As Long, k As Long, sh As Worksheet
Dim conn As Object, rs As Object
If Range("F6").Value = "" Then
    MsgBox "Lütfen aktarılacak sayfayı Yazınız.", vbCritical, "UYARI"
    Range("F6").Select
    Exit Sub
End If
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=Microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\A.xls;extended properties=""excel 8.0;hdr=no;"""
Set rs = conn.Execute("Select * from [" & Range("F6").Value & "$A1:K65536]")
If Workbooks.Open(ThisWorkbook.Path & "\B.xls").ReadOnly = True Then
    Workbooks("B.xls").Close
End If
ThisWorkbook.Activate
Set sh = Workbooks("B.xls").Sheets(Range("F6").Value)
sh.Range("A1:K100").ClearContents
sh.Range("A1").CopyFromRecordset rs
conn.Close
Set rs = Nothing
Set conn = Nothing
Workbooks("B.xls").Close True
MsgBox "Kapalı A.xls Dosyasında Sayfa1 deki A1:K100 aralığındaki veriler," & vbLf & _
"B.xls dosyasında Sayfa1 A1:K100 aralığına kopyalandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[pylor]

merhaba acaba bu msjım evren beye ulaştımı

 

[pylor]

sayın evren gizlen excel hakkında birkaç sorum olacak sorabilirmiyim acaba

 

[pylor]

Sayın Evren Gizlen Excel Hakkında Birkaç Sorum Olacak Sorabilirmiyim Acaba

 

[pylor]

Sayın Evren Gizlen Excel Hakkında Birkaç Sorum Olacak Sorabilirmiyim Acaba

 

[Korhan Ayhan]

Selamlar,

Neden sürekli aynı mesajları yazıyorsunuz. Direkt olarak sorularınızı sorabilirsiniz.

 

[blaster2005]

Bunuda ado kullanarak yaptım.
Diğer yönteme göre daha hızlı çalışıyor.
Dosya ektadir.
Bütün dosyaların ayni klasörde olamsı lazımdır.

Sub ADO_ile_kapali_A_Dosyasından_B_dosyasina_Kayit()
Dim i As Long, k As Long, sh As Worksheet
Dim conn As Object, rs As Object
If Range("F6").Value = "" Then
    MsgBox "Lütfen aktarılacak sayfayı Yazınız.", vbCritical, "UYARI"
    Range("F6").Select
    Exit Sub
End If
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=Microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\A.xls;extended properties=""excel 8.0;hdr=no;"""
Set rs = conn.Execute("Select * from [" & Range("F6").Value & "$A1:K65536]")
If Workbooks.Open(ThisWorkbook.Path & "\B.xls").ReadOnly = True Then
    Workbooks("B.xls").Close
End If
ThisWorkbook.Activate
Set sh = Workbooks("B.xls").Sheets(Range("F6").Value)
sh.Range("A1:K100").ClearContents
sh.Range("A1").CopyFromRecordset rs
conn.Close
Set rs = Nothing
Set conn = Nothing
Workbooks("B.xls").Close True
MsgBox "Kapalı A.xls Dosyasında Sayfa1 deki A1:K100 aralığındaki veriler," & vbLf & _
"B.xls dosyasında Sayfa1 A1:K100 aralığına kopyalandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

İhtiyacım olan şey sanırım bu. çok güzel çalışmalarınız var öncelikle sizi tebrik ediyorum.
ihtiyacım olan şey ise şu. aynı şekilde otomatik kitap kopyalama lazım. ama makro her çalıştırmamda kitabı bütün sayfalarıyla birlikte kopyalasın, yeni isimde bir kitap oluştursun (kitap ismini x sayfasının F2 sütunundan alsın) ve yeni oluşturduğu kitaba kopyalamayı yaptıktan sonra, sadece bir sayfasının F2 den itibaren tüm F sütunundaki rakamı bir artırsın. ( istediğim şeyi manuel olarak şöyle yapıyorum. kitabı açıyorum F2 den itibaren F sütunun değerini 1 artırıyorum örn. 1000 ise 1001 yapıyorum. farklı kaydet yapıyorum kitabın ismine 1001 deyip kaydediyorum. bunu otomatikleştirmem lazım) Saygılar.