Burdan Sonrası İçin Yardım Edermisiniz Lutfen ( Vba koddaki Sayfa Sayısını arttırmak)

[cenderus]

Sub VERİLERİ_GÜNCELLE()
    Application.ScreenUpdating = False
    Dosya_Yolu = "C:\Documents and Settings\admin\Desktop\ANA DOSYA\1"
    Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa1")
    S1.Select
    [A2:FD65536].ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xls") > 0 Then
    If Dosya.Name <> "ANA DOSYA.xls" Then
    Workbooks.Open Filename:=Dosya
    Sheets("Sayfa1").Select
    Range("A2:FD" & [FD65536].End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Veriler aktar&#305;lm&#305;&#351;t&#305;r.", vbInformation
End Sub

bu kodu birden fazla sayfa için nasıl uyarlarım;


orneğin sayfa2 yi sayfa 2 ye sayfa 3 sayfa 3 'e gibi birden fazla sayfa nasıl eklerim

 

[Levent Menteşoğlu]

Ne yapmak istediğinizi detaylıca anlatırsanız sanıyorum daha pratik çözümler bulunabilir.

 

[cenderus]

kısa yolu varmı

hocam daha once defalarca yazdım insanlara uzun geliyor yanıtlamaya tenezzül etmiyorlar ;

bu kodu adapte ettim ama işlem çok uzun suruyor bu kodu kısalta bilirmiyiz;

4 sayfanın herbirinde içeriği ve sayfa adı farklı sheetler var birde hepsinini içeren anadosya var ben bir tusa atayacağım kod ile bu dosyalardaki guncel verileri ana dosyaya kopylamak istedim toplamda 4 veri dosyası bunlardada toplamda 54 sheet var
bu kodu kendime revize ettim ama iki sayfa için bunu 4 dosya 52 sayfa için yapacağım sanırım kolayı yoksa eğer

Sub VERİLERİ_GÜNCELLE()
    Application.ScreenUpdating = False
    Dosya_Yolu = "C:\Documents and Settings\strkkobya\Desktop\ANA DOSYA\1\"
    Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa1")
    S1.Select
    [A29:FD6000].ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xls") > 0 Then
    If Dosya.Name <> "ANA DOSYA.xls" Then
    Workbooks.Open Filename:=Dosya
    Sheets("Sayfa1").Select
    Range("A29:FD6000" & [FD6000].End(3).Row).Copy S1.Cells(6000, 1).End(3).Offset(1)
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa2")
    S1.Select
    [A29:FD6000].ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xls") > 0 Then
    If Dosya.Name <> "ANA DOSYA.xls" Then
    Workbooks.Open Filename:=Dosya
    Sheets("Sayfa2").Select
    Range("A29:FD6000" & [FD6000].End(3).Row).Copy S1.Cells(6000, 1).End(3).Offset(1)
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub

 

[Levent Menteşoğlu]

Bu iş için bence ADO kullanmak en hızlı çözümdür. Öncelikle bu dört veri dosyanızın yapısı birbirinin aynısımıdır? eğer öyle ise bir tane örnek dosya eklermisiniz. Birde bu veriler veri alınacak dosyaya ne şekilde aktarılacaktır. Örneğin alt altamı?

 

[cenderus]

hocam haluk hocanın kodlarından yola çıktım bende ama ADO hakkında hiçbir fikrim olmadığı için boyle bir çözüm buldum ama çok uzun suruyor ve pcyi kitliyor yapmak istediğim

ana dosya adı genel.xls

veri iceren dosyalar 1.xls ve 2.xls

genel dosyası ar - br - cr - dr- er - fr sheetlerinden oluşuyor

1 dosyası ar - br - cr sheetlerinden oluşuyor

2 dosyası dr - er - fr sheetlerinden oluşuyor


genel dosyasına atayacağım bir command bottona nasıl bir kod girmeliyim ki



kapalı olan 1 dosyasındaki ar - br - cr sheetlerindeki sutunda a - fd ,satırda 29- 3000 nci satıra kadar olan kısmı genel dosyasındaki a - b - c sheetlerindeki sutunda a - fd ,satırda 29- 3000 nci satıra kopyalasın tabi her sheeti aynı adı taşıyan geneldeki yerine orneğin


1 deki ar sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığını geneldeki ar sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına
1 deki br sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığını geneldeki br sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına
1 deki cr sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına geneldeki cr sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına

kapalı olan 2 dosyasındaki er - fr - gr sheetlerindeki sutunda a - fd ,satırda 29- 3000 nci satıra kadar olan kısmı genel dosyasındaki er - fr - gr sheetlerindeki sutunda a - fd ,satırda 29- 3000 nci satıra kopyalasın tabi her sheeti aynı adı taşıyan geneldeki yerine orneğin


2 deki er sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığını geneldeki er sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına
2 deki fr sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığını geneldeki fr sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına
2 deki gr sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına geneldeki gr sayfasındaki sutunda a - fd ,satırda 29- 3000 aralığına

gibi açıklayabilriim

 

[Levent Menteşoğlu]

Ben dosyalarınızı e:\sample isimli klasöre kopyalayıp, kodu ona göre düzenledim. Siz bu yolu kendinize göre değiştirirsiniz. Kod oldukça hızlı çalışacaktır.

Sub verilerial()
dosyaadi = Array("dat1", "dat2", "dat3")
Set baglanti = CreateObject("ADODB.Connection")
Set sayfalar = CreateObject("ADOX.Catalog")
For a = 0 To UBound(dosyaadi)
baglanti.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=E:\sample\" & dosyaadi(a)
sayfalar.ActiveConnection = baglanti
For Each sayfa In sayfalar.Tables
sayfaadi = Replace(Left(sayfa.Name, Len(sayfa.Name) - 2), "'", "")
Set rs = baglanti.Execute("[" & sayfaadi & "$a28:fd3000]")
Sheets(sayfaadi).[a29].CopyFromRecordset rs
Next
rs.Close
baglanti.Close
Next
End Sub

 

[cenderus]

hocam çok tesekkur ederim

hocam çok tesekkur ederim, değerli bilginizi benimle paylaştığınız ve bu kritik soruma cevap verdiğiniz için siz olmasaniz ilk kodu saatlerce kopyalayacaktım gerçi ilk 26 bitmişti ve ilk denememde pc kitlenmişti sizin kodunuz ile çok kısa surede işlem tamamlanıyor ,

size tekrar tekrar teşekkur ediyorum

 

[Levent Menteşoğlu]

Rica ederim. Sorununuzun çözüldüğüne sevindim.

 

[cenderus]

Değerli hocam

Hocam kodu size gonderdiğim ornek üzerinde ilk denediğimde çalıştı hatta birkaç deneme yaptım yine çalıştı bundan sonrada kodu aşağıdaki gibi değiştirdim


Run-time error'-2147217900 (80040e14)':
[Microsoft][ODBC Excel Driver] Invalid SQL statement;expected
'DELETE','INSERT','PROCEDURE','SELECT',or'UPDATE'.


ve aşağıdaki satırda hata veriyor

Sub verilerial()
dosyaadi = Array("dat1", "dat2", "dat3")
Set baglanti = CreateObject("ADODB.Connection")
Set sayfalar = CreateObject("ADOX.Catalog")
For a = 0 To UBound(dosyaadi)
baglanti.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=D:\sample\" & dosyaadi(a)
sayfalar.ActiveConnection = baglanti
For Each sayfa In sayfalar.Tables
sayfaadi = Replace(Left(sayfa.Name, Len(sayfa.Name) - 2), "'", "")
Set rs = baglanti.Execute("[" & sayfaadi & "$a28:fd3000]")
Sheets(sayfaadi).[a29].CopyFromRecordset rs
Next
rs.Close
baglanti.Close
Next
End Sub

bu satırda takılıyor

Set rs = baglanti.Execute("[" & sayfaadi & "$a28:fd3000]")

kodu

Sub verilerial()
dosyaadi = Array("1", "2", "3")
Set baglanti = CreateObject("ADODB.Connection")
Set sayfalar = CreateObject("ADOX.Catalog")
For a = 0 To UBound(dosyaadi)
baglanti.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=D:\sample\" & dosyaadi(a)
sayfalar.ActiveConnection = baglanti
For Each sayfa In sayfalar.Tables
sayfaadi = Replace(Left(sayfa.Name, Len(sayfa.Name) - 2), "'", "")
Set rs = baglanti.Execute("[" & sayfaadi & "$a28:fd3000]")
Sheets(sayfaadi).[a29].CopyFromRecordset rs
Next
rs.Close
baglanti.Close
Next
End Sub

şeklinde dosya adı ile değiştirince

bu seferde

rs.Close

kısmında takıldı

anlayamadıgım iki hatanında birbirinden bağımsız hatalar oldugunu tahmin ediyorum


yapmış oldugum tek değişiklik

dat dosyalarının içine metin ve sayısal veri girmek ki veri aralığı aynı;