birden fazla kitaptan veri almak

[ali14]

Merhaba arkadaşlar proje bakalım nasıl olcak şimdi:
bilmiyorum cok mu abarttım ama bir makro ile asagıdaki konuyu cöze bilirmiyiz
Elimizde 10 ad.Çalışma kitabı var diyelim Kitap adları veri-1,veri-2 diye gidiyo ve her kitapta 20 ad.sayfa var analiz-1,analiz,2 diye
Ana sayfamızda yani bura Sonuc ben bu sayfadaki butona basınca veri güncellensin
yukarda 5.satır diğer sayfadan yani analiz-1 dan ilgili sutunlardaki veriyi alıp
sonra diğer satır yani analiz-2 sayfasına gececek burda tum sayfalarda alıncak sutunlar aynı tek farkı sayfa lar değiscek ve o kitaptaki tum sayfalar bitince diger sutunda diger kitaba gecip diger aynı sutunları alcak.
Burda eniyi olan tüm kitaplarda tüm sayfalardan aynı sutunlar alıncak
Saygılar
ali

 

[Orion1]

Veri dosyalarında en üstte başlık satırı olmalı ve başlıklar birleştirilmiş hücre olmamalıdır.
Proje dosyası diğer dosyalarla ayni klasörde olmalıdır.
Diğer dosyalarda bulunan sayfalar proje dosyasındada olmalıdır.
Dosyanız ektedir.

Sub Dosya_Aktar()
Dim conn As ADODB.Connection, rs As ADODB.Recordset, yol As String
Dim fs As Object, sat As Long, sf As Object, dsy As Object, i As Integer, baglandi As Boolean
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
yol = ThisWorkbook.Path
Set fs = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files
For Each dsy In fs
    If Right(dsy.Name, 4) = ".xls" Then
        If dsy.Name <> ThisWorkbook.Name Then
            conn.Open "Provider=Microsoft.Jet.Oledb.4.0;data source=" & yol & "\" & dsy.Name & _
            ";extended properties=""Excel 8.0;hdr=yes;"""
            baglandi = True
                For i = 2 To Worksheets.Count
                    rs.Open "Select * from " & Sheets(i).Name & ";"
                    sat = Cells(65536, "A").End(xlUp).Row + 1
                    Range("A" & sat).CopyFromRecordset rs
                    rs.Close
                Next i
        End If
    End If
Next
If baglandi = True Then conn.Close
End Sub

 

[ali14]

sayın Evren öncelikle zaman ayırdıgın için tesekkurler.
Ben bu dosyayı indirdim ama benim istegim bu deil.Benim yapmaya calıstıgım proje sayfasına kitaplardan veri almak aktamak deil
Yani butona basınca Proje adındaki dosyamın 5. satırına Veri-1 adlı kitabin Analiz-1 adlı sayfasından B sütununun 213. satırını alcam
sonra proje sayfasının 6.satırına gececek iste böle devam edecek.
Yani benim gönderdigim proze dosyasındaki 5.satırda yazan (Analiz-1'!B213) analiz -1 kitabının B213 ünü al Analiz-1'!A216
diye örnek gösterdim
Zaman ayırabilirseniz tesekkür ederim.
Saygılar
Ali

 

[Orion1]

sayın Evren öncelikle zaman ayırdıgın için tesekkurler.
Ben bu dosyayı indirdim ama benim istegim bu deil.Benim yapmaya calıstıgım proje sayfasına kitaplardan veri almak aktamak deil
Yani butona basınca Proje adındaki dosyamın 5. satırına Veri-1 adlı kitabin Analiz-1 adlı sayfasından B sütununun 213. satırını alcam
sonra proje sayfasının 6.satırına gececek iste böle devam edecek.
Yani benim gönderdigim proze dosyasındaki 5.satırda yazan (Analiz-1'!B213) analiz -1 kitabının B213 ünü al Analiz-1'!A216
diye örnek gösterdim
Zaman ayırabilirseniz tesekkür ederim.
Saygılar
Ali

Dosyayı çalıştırmadan yorum yapmışsınız.Zaten bu kodlar verileri alıyor.Yani dier kitaptan bu kitapa aktarıyor.
Başka bir dosyayda uygulayacaksanız referanslardan microsoft activex dataobject 2.x library seçeniğini işaretlemeniz gerekiyor.

 

[ali14]

Evren bey ben dosyayı deminde indirmistim gene indirdim gene denedim.
Gine cok tesk ediyorum cunku en azından urasıyosunuz zaman ayırıyosunuz bu bile büyük bir özver. saolun.

Sıkıntıya gelince proje kitabı sayfa2 deki güncelleye basınca şu hatayı veriyo
conn As ADODB.Connection
ve benim sizin gönderdiginiz makroda benim istedigim sutunları almıyo sadece o sayfayı komple almıs.
Ben kimse benle cok zaman kaybetmesin diye iki sayfa adı verdim yani o makro bana iskelet olsun
bende makronun içine girip diger sayfa ve kodları iskelete bakarak kendim ekleyim diye
Böylece yardım sever arkadaslar diğer insanlarada daha fazla yardım etmis olur diye.
Ali Simsek

 

[Orion1]

Evren bey ben dosyayı deminde indirmistim gene indirdim gene denedim.
Gine cok tesk ediyorum cunku en azından urasıyosunuz zaman ayırıyosunuz bu bile büyük bir özver. saolun.

Sıkıntıya gelince proje kitabı sayfa2 deki güncelleye basınca şu hatayı veriyo
conn As ADODB.Connection
ve benim sizin gönderdiginiz makroda benim istedigim sutunları almıyo sadece o sayfayı komple almıs.
Ben kimse benle cok zaman kaybetmesin diye iki sayfa adı verdim yani o makro bana iskelet olsun
bende makronun içine girip diger sayfa ve kodları iskelete bakarak kendim ekleyim diye
Böylece yardım sever arkadaslar diğer insanlarada daha fazla yardım etmis olur diye.
Ali Simsek

Başka bir dosyayda uygulayacaksanız referanslardan microsoft activex dataobject 2.x library seçeniğini işaretlemeniz gerekiyor.

Bu yukarıdaki dediğimi yaptınızmı?
Ben bütün sütunları almak istemiyorum demişsiniz.Peki sadece belli bir hücreyimi / hücrelerimi alacaksınız. bunlar hangi hücreler olacak.Bunu açıklaranız ona göre kod yazayım.Birde listelenecek sayfada baştan hepsi silinip tekrarmı bulnanlar yazılsın.Birde bir sayfa için yapın ben diğer sayfalar için uygularım demişsiniz.Buna gerek tok .Ben döngüye girerek bütün sayfaları aktarıcağım.Buda ilk sayfa hariç 2nci sayfada döngüye girip olacak.

 

[ali14]

Iyi aksamlar

Arkadaslar herkese iyi aksamlar .
Evren bey biliyorum bütün sorun benim ne istediğimi tam anlatamadığımdan kaynaklanıyo.
ha bu arada hakikaten burda tüm konulara cevap yazan arkadaslara kendi adıma tsk.çünkü hepiniz kendi zamanlarınızdan fedakarlık yapıp hiç bir mecburiyetiniz olmadan yardımcı oluyorsunuz emekleriniz içinde ayrıca tsk.
ney se ben aynı konu ile ilgili bir dosyadaha ekliyom umarım derdimi anlatabilirim.

 

[Orion1]

Excel4 makrosu ile yaptım.
Veri dosyalarından analiz-1 sayfalarından veriler alınıyor.
Dosyanız ektedir.

Sub kapali_aktar()
Dim fso As Object, f As Object, sat As Long, i As Byte, dsy
Dim suta, satb, sutb
suta = Array("", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG")
satb = Array(0, 213, 216, 216, 217, 217, 217, 238, 238, 239, 239, 240, 240, 241, 241, 242, 242, 243, 243, 231, 231, 232, 232, 233, 233, 234, 234, 235, 235, 236, 236, 237, 237, 228)
sutb = Array(0, 2, 1, 2, 3, 4, 5, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 6, 7, 1)


Sheets("ana sayfa").Select
Application.ScreenUpdating = False
Range("A3:AG65536").ClearContents
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.Path).Files
sat = 3
With Sheets("Sayfa1")
    For Each dsy In f
        If dsy.Name <> ThisWorkbook.Name And Right(dsy.Name, 4) = ".xls" Then
            If sat >= 65533 Then
                MsgBox "Satır doldu başka kayıt yapamazsınız.", vbCritical, "UYARI"
                Exit Sub
            End If
            For i = 1 To 33
                Cells(sat, suta(i)) = _
                Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" _
                & dsy.Name & "]Analiz-1'!R" & satb(i) & _
                "C" & sutb(i))
            Next i
            sat = sat + 1

        End If
    Next
End With
Application.ScreenUpdating = True
MsgBox "Veriler Alındı.", vbOKOnly + vbInformation, "VERİ ALINDI"
End Sub