• DİKKAT

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

Kapalı Excel Kitabından Veri Alma - ADO Yöntemi

A

a long time ago

Katılım
23 Şubat 2010
Mesajlar
90
Excel Vers. ve Dili
Excel 2007/ İngilizce
Herkese merhaba,

Öncelikle forumda ADO uygulamalarını arattım ama bulduğum sonuçları kendi çalışmama adapte edemedim. Açıkçası çok hakim de olamadım ADOlara.

Aşağıda kodlarını gördüğünüz çalışmada "Follow Up" isimli çalışmadan belli hücrelerdeki değerleri "EK 2012" e aktarmak istiyorum. Ayrıca bir döngüde söz konusu bu veri alma işleminde.

Fakat her iki kitap arasında gerekli bağlantıyı kuramadım. Bu konuda yardımcı olabilirseniz memnun olurum. Ayrıca sadece ADO ile değil diğer yöntemleri de paylaşabilirsiniz. Şimdiden teşekkürler.

Kod: 
Sub eti_fecr()
Sheets("DATABASE").Select
Dim rn, a As Integer
Dim SearchRange As Range
Dim FindRow As Range
rn = 3
a = 7

Set SearchRange = Range("A3", Range("A500").End(xlUp))
Set FindRow = SearchRange.Find("FOLLOWING SHIPMENTS", LookIn:=xlValues, lookat:=xlWhole)
y = FindRow.Row

For rn = 3 To y - 1
            If Sheets("Follow Up").Cells(rn, 8).Value = "eta" Or _
            Sheets("Follow Up").Cells(rn, 6).Value = "" Then
            GoTo hata
            Else
                With Workbooks("EK 2012.xlsm").Sheets("DATABASE")
                .Cells(a, 1).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 4)
                '.Cells(a, 2).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 5)
                '.Cells(a, 3).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 5)
                .Cells(a, 4).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 6)
                .Cells(a, 5).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 18)
                .Cells(a, 6).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 19)
                .Cells(a, 7).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 20)
                .Cells(a, 8).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 21)
                .Cells(a, 9).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 22)
                .Cells(a, 10).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 11)
                .Cells(a, 11).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 12)
                .Cells(a, 12).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 68)
                .Cells(a, 13).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 17)
                .Cells(a, 14).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 15)
                a = a + 1
                End With
            End If
hata:
Next rn
End Sub
 
Merhaba Murat,

evet alakası yok :) çünkü açıkçası beceremedim. alternatif bir yol olur mu diye de sordum aslında..

verdiğin linke bakıyorum umarım becerebilirim.

teşekkürler
 
Takıldığınız yerde sorarsınız.
Olmadı en sağlamı örnek dosya eklersiniz, çözmeye çalışırız...
 
Murat OSMA' Alıntı:
Takıldığınız yerde sorarsınız.
Olmadı en sağlamı örnek dosya eklersiniz, çözmeye çalışırız...
Genişletmek için tıkla ...

Teşekkürler Murat :)

Verdiğin kod ile biraz çalıştım ama "external table is not in the expected format" hatası aldım. Kapalı olan çalışma hem makro bulunduruyor hem de şifreli. Karşılaştığım hata bu sebeple olabilir mi?

Aşağıda güncellediğim kod mevcut. Bir mantık hatası varsa ve sölerseniz memnun olurum :)

Kod: 
Sub eti_fecr()
Sheets("DATABASE").Select
Dim rn, a As Integer
Dim SearchRange, FindRow As Range
Dim con As Object, cat As Object
rn = 3
a = 7


Set con = CreateObject("adodb.connection")
Set cat = CreateObject("adox.catalog")

evn = ThisWorkbook.Path & "\Follow Up-2012.xlsm"
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data source=" & evn & "; [B][B][COLOR="Blue"]Jet OLEDB:Database Password=ft[/COLOR][/B][/B]; extended properties=""excel 8.0;hdr=no"""

cat.ActiveConnection = con


Set SearchRange = Range("A3", Range("A500").End(xlUp))
Set FindRow = SearchRange.Find("FOLLOWING SHIPMENTS", LookIn:=xlValues, lookat:=xlWhole)
y = FindRow.Row

For rn = 3 To y - 1
            If Sheets("Follow Up").Cells(rn, 8).Value = "eta" Or _
            Sheets("Follow Up").Cells(rn, 6).Value = "" Then
            GoTo hata
            Else
                With Workbooks("EK 2012").Sheets("DATABASE")
                .Cells(a, 1).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 4)
                '.Cells(a, 2).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 5)
                '.Cells(a, 3).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 5)
                .Cells(a, 4).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 6)
                .Cells(a, 5).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 18)
                .Cells(a, 6).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 19)
                .Cells(a, 7).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 20)
                .Cells(a, 8).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 21)
                .Cells(a, 9).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 22)
                .Cells(a, 10).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 11)
                .Cells(a, 11).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 12)
                .Cells(a, 12).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 68)
                .Cells(a, 13).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 17)
                .Cells(a, 14).Value = Workbooks("Follow Up-2012.xlsm").Sheets("Follow Up").Cells(rn, 15)
                a = a + 1
                End With
            End If
hata:
Next rn


con.Close: sayfaad = vbNullString: evn = vbNullString
Set cat = Nothing: Set con = Nothing

End Sub
 
Örnek dosya olmadan çözebilmem çok zor...
Özel mesajda da dediğim gibi; orjinal dosya olmasa da en azında sayfa ismi - alınacak hücrelerin yerleri ve verileri alacağınız hücrelerin yerlerini gösteren bir dosya eklemelisiniz...

Aldığınız hata ise Excel sürümünüz ile alâkalı, connectionstrings şu şekilde olmalı;
"Provider=Microsoft.ace.oledb.12.0;Data Source= " & evn & "; extended Properties="Excel 12.0;hdr=no;"")
 
Murat OSMA' Alıntı:
Örnek dosya olmadan çözebilmem çok zor...
Özel mesajda da dediğim gibi; orjinal dosya olmasa da en azında sayfa ismi - alınacak hücrelerin yerleri ve verileri alacağınız hücrelerin yerlerini gösteren bir dosya eklemelisiniz...

Aldığınız hata ise Excel sürümünüz ile alâkalı, connectionstrings şu şekilde olmalı;
"Provider=Microsoft.ace.oledb.12.0;Data Source= " & evn & "; extended Properties="Excel 12.0;hdr=no;"")
Genişletmek için tıkla ...

Murat tekrar çok teşekkürler. Son yazdığın değişikliği yapınca düzeldi. :) Sabrın için de teşekkürler :)
 
Rica ederim, iyi akşamlar. :)
 
ADO Oluşturma

Herkese Günaydın,

Örnek bir çalışma yapmadan olmayacak sanırım. Dün bazı kısımlara çözüm buldum ama sonuçta kapalı bir excel kitabından açık olan başka bir kitaba veri alamıyorum :(

Ekte örnek çalışma mevcut. Ado ile "Açık.xlsm" isimli dosyaya "Kapalı.xlsm" isimli dosyadan nasıl veri çekebilirim?

Kısaca açıklamak gerekirse Kapalı isimli dosyanın belli sütunlarındaki değerleri "Açık.xlsm"'nin belli sütunlarına aktarmak istiyorum. Kodun o kısmında sorun yok. Sadece kapalı olan dosyaya bağlantıda sorun yaşıyorum.

Şimdiden teşekkürler ve herkese iyi günler :)
 

Ekli dosyalar

Merhaba isminiz neydi acaba ?
 
Görkem... Erkek ? Bayan ? :dusun:

Kodları Kapalı.xlsm dosyasındaki tüm sütunları alacak şekilde hazırladım.
Ama siz hangi sütunların, hangi koşula göre alınacağını belirtirseniz; ona göre revize ederim.

Kodlar şu şekilde:
Kod: 
[SIZE="2"]Sub eti_fecr()
    Dim con As Object, rs As Object
    Dim evn As String

    Application.ScreenUpdating = False

    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    
    Range("A2:T50").ClearContents
    
    evn = ThisWorkbook.Path & "\Kapalı.xlsm"
    con.Open "Provider=Microsoft.ace.oledb.12.0;Data source=" & evn & _
    "; Jet OLEDB:Database Password=ft; extended properties=""excel 12.0;hdr=no"""
    
    rs.Open "Select * from [Follow Up$] ", con, 1, 1
    Range("A65536").End(3)(2, 1).CopyFromRecordset rs
    Range("a2:t50").CurrentRegion.Borders.LineStyle = 1
    
    Columns.AutoFit
    
    rs.Close: con.Close: evn = vbNullString
    Set rs = Nothing: Set con = Nothing

    Application.ScreenUpdating = True
End Sub[/SIZE]
 
Murat OSMA' Alıntı:
Görkem... Erkek ? Bayan ? :dusun:

Kodları Kapalı.xlsm dosyasındaki tüm sütunları alacak şekilde hazırladım.
Ama siz hangi sütunların, hangi koşula göre alınacağını belirtirseniz; ona göre revize ederim.

Kodlar şu şekilde:
Kod: 
[SIZE="2"]Sub eti_fecr()
    Dim con As Object, rs As Object
    Dim evn As String

    Application.ScreenUpdating = False

    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    
    Range("A2:T50").ClearContents
    
    evn = ThisWorkbook.Path & "\Kapalı.xlsm"
    con.Open "Provider=Microsoft.ace.oledb.12.0;Data source=" & evn & _
    "; Jet OLEDB:Database Password=ft; extended properties=""excel 12.0;hdr=no"""
    
    rs.Open "Select * from [Follow Up$] ", con, 1, 1
    Range("A65536").End(3)(2, 1).CopyFromRecordset rs
    Range("a2:t50").CurrentRegion.Borders.LineStyle = 1
    
    Columns.AutoFit
    
    rs.Close: con.Close: evn = vbNullString
    Set rs = Nothing: Set con = Nothing

    Application.ScreenUpdating = True
End Sub[/SIZE]
Genişletmek için tıkla ...

Murat,

İsim kafa karıstırıcı evet :/ cevabım erkek :)

Öncelikle yardımın için çok teşekkürler.

Sütun konusuna gelince..

Öncelikle kapalı olan dosyanın A sütununda "Following Shipments" ifadesinin hangi satırda olduğunu bulmam gerekiyor.

Çünkü o satırın altında kalan alanı işin içine dahil etmiyorum. O yuzden benim hazırladığım kodda "for next" döngüsü vardı. Bu 1. koşulum.

Diğer koşul ise seçtiğim sütunlar.. Birbirini takip etmeyen sütunları seçtiğim için yine yazdığım kodda olduğu gibi olması gerekiyor.

Örneğin kapalı dosyanın C sütunundaki verileri ilk koşula bağlı kalmak şartı ile açık dosyanın L sütuna yerleştirmem lazım..

Tek bir örnekle yardımcı olabilirsen gerisini ben tamamlarım diye düşünüyorum :)

Yazdığın koda "For next" döngüsünü ekleme şansım var mı?
 
Murat OSMA' Alıntı:
Görkem... Erkek ? Bayan ? :dusun:

Kodları Kapalı.xlsm dosyasındaki tüm sütunları alacak şekilde hazırladım.
Ama siz hangi sütunların, hangi koşula göre alınacağını belirtirseniz; ona göre revize ederim.

Kodlar şu şekilde:
Kod: 
[SIZE="2"]Sub eti_fecr()
    Dim con As Object, rs As Object
    Dim evn As String

    Application.ScreenUpdating = False

    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    
    Range("A2:T50").ClearContents
    
    evn = ThisWorkbook.Path & "\Kapalı.xlsm"
    con.Open "Provider=Microsoft.ace.oledb.12.0;Data source=" & evn & _
    "; Jet OLEDB:Database Password=ft; extended properties=""excel 12.0;hdr=no"""
    
    rs.Open "Select * from [Follow Up$] ", con, 1, 1
    Range("A65536").End(3)(2, 1).CopyFromRecordset rs
    Range("a2:t50").CurrentRegion.Borders.LineStyle = 1
    
    Columns.AutoFit
    
    rs.Close: con.Close: evn = vbNullString
    Set rs = Nothing: Set con = Nothing

    Application.ScreenUpdating = True
End Sub[/SIZE]
Genişletmek için tıkla ...

Merhaba Murat,

Tekrar bakabildin mi acaba? Teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst