• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

makro ile kapalı dosyalardan girilen bilgiye göre veri getirmek

M

Mavi Deniz

Katılım
25 Mayıs 2012
Mesajlar
23
Excel Vers. ve Dili
excel 2007 türkçe
merhabalar değerli exel üstadlarım
ekte gönderdiğim dosyalarda yapılacak olan aramayı yapabilirmiyiz acaba, gerekli açıklamaları ARAMA DOSYASINA yazdım eğer bu konuda bana yardım ebelirseniz inianın çok mutlu olurum. Allahım, şimdiden yardım elini uzatabilecek değerli excel üstadlarımın işlerini kolaylaştırsın, her iki dünyada da yardımcısı olsun inşallah..
 

Ekli dosyalar

Şu kodları kullanabilirsiniz;

Kod: 
Sub Kapalı_Dosyalardan_Veri_Al()
    Dim con As Object, kat As Object, tbl As Object, fso As Object
    Dim Dosya As Object, Sayfa As Object, syf As String, yol As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set con = CreateObject("adodb.connection")
    Set kat = CreateObject("adox.catalog")
    Set tbl = CreateObject("adox.table")
    yol = ThisWorkbook.Path
    For Each Dosya In fso.getfolder(yol).Files
        If Dosya.Name <> "ARAMA DOSYASI.xls" Then
            con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;hdr=no"""
            kat.activeconnection = con
                For Each Sayfa In kat.tables
                    If Sayfa.Type = "TABLE" And Right(Sayfa.Name, 1) = "$" Then
                        syf = Replace(Sayfa.Name, "$", "")
                        Set rs = con.Execute("select * from [" & Sayfa.Name & "C75:G95] where f5='DEVLET' and not isnull(f5)")
                        Range("C65536").End(3)(2, 1).CopyFromRecordset rs
                        son = Range("C65536").End(3).Row
                        Cells(son - 1, 1) = Replace(Dosya.Name, ".XLS", "")
                        Cells(son - 1, 2) = syf
                    End If
                Next Sayfa
            con.Close
        End If
    Next Dosya
    Set con = Nothing: Set kat = Nothing: Set tbl = Nothing: Set fso = Nothing
    Set Dosya = Nothing: Set Sayfa = Nothing: yol = "": syf = ""
End Sub
 
merhaba murta bey ilgi ve alakanız için çok teşekkür ederim Allah sizden razı olsun.. eğer mümkünse bir şey daha istiyorum, ARAMA DOSYASINA D42 satırına arayacığımız ŞİRKET (ASİL, DEVLET, VAKIF vs) girdikten sonra arama yapıp, önce öğle sayfasının sonra akşam sayfasının verilerini satırların hepsini doldurarak getirtebilirmiyiz yani öğle ve akşam aralarındaki boş olana yerler ve tarihler de yazsın istiyorum. mümkün olabilirmi acaba, kolay gelsin... ekteki dosyada umarım daha iyi anlatmışımdır....
 

Ekli dosyalar

Murat OSMA' Alıntı:
Şu kodları kullanabilirsiniz;

Kod: 
Sub Kapalı_Dosyalardan_Veri_Al()
    Dim con As Object, kat As Object, tbl As Object, fso As Object
    Dim Dosya As Object, Sayfa As Object, syf As String, yol As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set con = CreateObject("adodb.connection")
    Set kat = CreateObject("adox.catalog")
    Set tbl = CreateObject("adox.table")
    yol = ThisWorkbook.Path
    For Each Dosya In fso.getfolder(yol).Files
        If Dosya.Name <> "ARAMA DOSYASI.xls" Then
            con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;hdr=no"""
            kat.activeconnection = con
                For Each Sayfa In kat.tables
                    If Sayfa.Type = "TABLE" And Right(Sayfa.Name, 1) = "$" Then
                        syf = Replace(Sayfa.Name, "$", "")
                        Set rs = con.Execute("select * from [" & Sayfa.Name & "C75:G95] where f5='DEVLET' and not isnull(f5)")
                        Range("C65536").End(3)(2, 1).CopyFromRecordset rs
                        son = Range("C65536").End(3).Row
                        Cells(son - 1, 1) = Replace(Dosya.Name, ".XLS", "")
                        Cells(son - 1, 2) = syf
                    End If
                Next Sayfa
            con.Close
        End If
    Next Dosya
    Set con = Nothing: Set kat = Nothing: Set tbl = Nothing: Set fso = Nothing
    Set Dosya = Nothing: Set Sayfa = Nothing: yol = "": syf = ""
End Sub
Genişletmek için tıkla ...

Merhaba Murat bey
Arkadaşın sorusu arada kaynamasın
arada cevap verebilirmisiniz

kodlarda
Kod: 
con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 12.0;hdr=no"""
            kat.activeconnection = con
kısmında hata veriyor
excel 2003 kullanıyorum bazı ayarlardanmı acaba?
ne yapmam gerekiyor
 
Mavi Deniz' Alıntı:
merhaba murta bey ilgi ve alakanız için çok teşekkür ederim Allah sizden razı olsun.. eğer mümkünse bir şey daha istiyorum, ARAMA DOSYASINA D42 satırına arayacığımız ŞİRKET (ASİL, DEVLET, VAKIF vs) girdikten sonra arama yapıp, önce öğle sayfasının sonra akşam sayfasının verilerini satırların hepsini doldurarak getirtebilirmiyiz yani öğle ve akşam aralarındaki boş olana yerler ve tarihler de yazsın istiyorum. mümkün olabilirmi acaba, kolay gelsin... ekteki dosyada umarım daha iyi anlatmışımdır....
Genişletmek için tıkla ...

Next Dosya

satırından sonra şu kodları ilave edin;

Kod: 
 For i = 54 To Range("A65536").End(3).Row
        If Cells(i, 1) = "" Then
            Cells(i, 1).Resize(, 2).FillDown
       End If
 Next i
 Range("A54:G" & Range("G65536").End(3).Row).Sort Range("B54"), 2
 
Numan Bey, mesajınızdan benim alıntıyı silebilir misin? Gereksiz yer kaplıyor.

2003 versiyonu için ConnectionString'i bu şekilde kullanın...
Kod: 
con.Open "Provider=Microsoft.jet.oledb.4.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 8.0;hdr=no"""
            kat.activeconnection = con
 
Murat OSMA' Alıntı:
Numan Bey, mesajınızdan benim alıntıyı silebilir misin? Gereksiz yer kaplıyor.

2003 versiyonu için ConnectionString'i bu şekilde kullanın...
Kod: 
con.Open "Provider=Microsoft.jet.oledb.4.0;Data Source=" & _
            Dosya & ";Extended Properties=""Excel 8.0;hdr=no"""
            kat.activeconnection = con
Genişletmek için tıkla ...

Teşekkürler Murat bey
 
Rica ederim Numan Bey, iyi akşamlar.
 
Sn. Mavi Deniz, yanıtsız kaldınız istediğiniz olmadı mı ? :dusun: :dusun:
 
Böylemi istiyorsunuz.
Dosyanız ektedir.:cool:
Kriterinizi büyük harfle giriniz.:cool:
Kod: 
Sub arama59ado()
Dim conn As Object, rs As Object, dosya As String, sat As Long
Dim sayfa As String
Sheets("Sheet1").Select
Range("A54:G65536").ClearContents
sirket = InputBox("ŞİRKET ADINI GİRİNİZ:", "ŞİRKET")
If sirket = "" Then Exit Sub
Application.ScreenUpdating = False
Set conn = CreateObject("ADODB.CONNECTION")
Set rs = CreateObject("ADODB.RECORDSET")
dosya = Dir(ThisWorkbook.Path & "\*.xls")
sat = 54
Do While dosya <> ""
    deg = UCase(Replace(Replace(Replace(dosya, ".XLS", ""), "i", "İ"), "ı", "I"))
    If deg <> "ARAMA DOSYASI.XLS" Then
        conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
            ThisWorkbook.Path & "\" & dosya & ";extended properties=""excel 8.0;hdr=no;imex=1"""
        sayfa = "ÖĞLE"
        For i = 1 To 2
            Cells(sat, "A").Value = CDate(deg)
            Cells(sat, "B").Value = sayfa
            rs.Open "select F1,F2,F3,F4,F5 from [" & sayfa & _
                "$C76:G65536] where F5='" & sirket & "';", conn, 1, 1
            If rs.RecordCount > 0 Then
                rs.movefirst
                Do While Not rs.EOF
                    Cells(sat, "C").Value = rs(0).Value
                    Cells(sat, "D").Value = rs(1).Value
                    Cells(sat, "E").Value = rs(2).Value
                    Cells(sat, "F").Value = rs(3).Value
                    Cells(sat, "G").Value = rs(4).Value
                    rs.movenext
                    Cells(sat, "A").Value = CDate(deg)
                    Cells(sat, "B").Value = sayfa
                    sat = sat + 1
                Loop
                sayfa = "AKŞAM"
            End If
            rs.Close
        Next i
        conn.Close
        Range("A54:G65536").Sort Range("A54")
    End If
    dosya = Dir
Loop
Application.ScreenUpdating = True
Set conn = Nothing
Set rs = Nothing
End Sub
 

Ekli dosyalar

Murat beyler cevap vermişler.
1 Tanede ben vereyim bari.:)
 
Murat Bey iyi akşamlar,
göndermiş olduğumuz kodları kopyaladım kodlar çalışıyor fakat bir hata var 01 ve 31 dosyalarında aranan ile ARAMA DOSYASINA gelenler birbirini tutmuyor. ayrıca bu kodlar acaba iki satıra göremi arıyor yoksa g sütünündaki veriye göremi arıyor. g sütünundaki DEVLET in karşısındaki satır ile komple arama dosyasına getirebilirmiyiz olurmu acaba?
teşekkürler...
 
pardon son gönderdiğinizi incelememiştim bi ona bakiim isterseniz murat bey,
 
10 nolu mesajdaki yaptığım dosyaya baktınızmı?
 
Orion1 çok teşekkürler göndermiş olduğunuz dosya tam istediğim gibi olmuş, allahım sizin ve murat bey'in ne muradı varsa versin, her iki dünyada da sizi rahat ettirsin çok teşekkürler :):):)
 
Orion1' Alıntı:
Murat beyler cevap vermişler.
1 Tanede ben vereyim bari.:)
Genişletmek için tıkla ...

Ne kadar çok örnek olursa o kadar iyi Evren Bey, ellerinize sağlık. :)


Yalnız, benim önerdiğim kodlar iş gördü mü onu tam anlamadım. :dusun:
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst