oledb ile başka sayfadan kitaptan veri çekme ( aynı kitaptan )

[hmtstc]

Merhaba,

sorgulama metodunu kapalı olan başka kitaplardan çekerken kullanabiliyorum. Ancak aynı kitapta başka bir sayfadan veri çekmek istiyorum. burada filtreler de olacak. ama aynı kitaptan çekerken nasıl ilerlemem gerektiğini anlayamadım. Yardımınızı rica ederim.

Sub grafiksorgu()
Dim son As Long
Application.ScreenUpdating = False
Sheets("Rapor").Select
sonsatır = Cells(Rows.Count, "E").End(xlUp).Row
If sonsatır = 1 Then sonsatır = 3
Range(Cells(2, 5), Cells(sonsatır, 11)).Select
Selection.ClearContents

son = "1048576"
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=No"""

    sorgu = "select F1,F2,F3,F4,F5,F6,F7 " & _
      "from[Duruşlar$A2:F" & son & "]"
    Set rs = con.Execute(sorgu)
    Range("A2").CopyFromRecordset rs
   
end sub

 

[YUSUF44]

Verdiğiniz kod zaten aynı dosya içindeki Duruşlar sayfasında A2:F1048576 aralığındaki tablodan sorgulama yapıyor. Filtreleme derken kriteri kastediyorsanız örneğin tablonun 1. sütunu "Ali" olanlar için:

sorgu = "select F1,F2,F3,F4,F5,F6,F7 " & _
"from[Duruşlar$A2:F" & son & "] where F1=Ali"

Şeklinde düzenleyebilirsiniz.

Bir de son değişkenini 1048576 olarak belirlemenize gerek yok. Bunun yerine son dolu satır olarak belirlemek daha pratik olur:

son = Sheets("Duruşlar").Cells(Rows.count,"A").End(3).Row

olarak kullanabilirsiniz, Duruşlar sayfasının A sütunundaki son satırı belirler.

İkinci olarak eğer Tablonuzda başlıklar varsa hdr=no yerine hdr=yes olarak belirtebilir ve tabloyu [Duruşlar$] olarak tanımlayabilir, F1,F2 gibi sütun başlıkları yerine de tablonuzdaki başlıkları yazabilirsiniz.

 

[hmtstc]

hocam öncelikle teşekkür ederim. ancak durum şu, bu sistemi başka bir excel kitabından sorgularken problem yok. ama aynı excel kitabı içinde, başka bir sayfadan rapor çekmek istediğimde kaynak bulunamadı hatası veriyor. aynı kitap içerisinde sorgu çekmeyi öğrenmek istiyorum. dediğinizi yaptım ama başaramadım.

 

[YUSUF44]

Aynı mesajımda ısrar ediyorum.

Aynı dosya içindeki tablodan sorgu yapmak için kullandığım ve aktif çalışan kodum şu şekilde:

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select Tarih,[Görev Yeri],[Hukuki Dayanağı],[Görev Konusu/Yapılan İşlem],[Başlama Saati],[Bitiş Saati],[Süre],[Araç Plakası/Yaya/Daire]" & _
  "from[Veri Girişi$] where [yıl] = " & yıl & " and [ay] = '" & ay & "' and [Ödeme] = '" & sure & "' "
 
Set rs = con.Execute(sorgu)
s2.Range("B7").CopyFromRecordset rs

Aynı şekilde aynı dosya içerisinde sorgu yapan hdr=no ve F1 düzenindeki kodum da şu şekilde:

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10 " & _
  "from[Data$A3:J" & son & "] where month(F6)=" & ay & " or month(F7)=" & ay & " or month(F8)=" & ay & "or month(F9)=" & ay

Set rs = con.Execute(sorgu)

[A5].CopyFromRecordset rs

Sizdeki sorunu anlayabilmemiz için örnek dosya paylaşmanız iyi olur.

 

[hmtstc]

merhaba, örnekleri denedim ama yine yapamadım. anlamadım hata nerde. dosya ektedir. kriterleri de rapor sayfasında belirttim.

şimdiden elinize sağlık teşekkür ederim.

 

[YUSUF44]

Aşağıdaki şekilde makro hazırladım ancak nedenini çözemediğim şekilde "Gerekli bir veya daha fazla parametre için girilen değer yok" hatası verdi:

Sub grafiksorgu()
Dim son As Long
Set s1 = Sheets("Rapor")
Set s2 = Sheets("Duruşlar")
eski = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "E").End(3).Row)
s1.Activate
s1.Range("E2:K" & eski).ClearContents
son = s2.Cells(Rows.Count, "A").End(xlUp).Row

If WorksheetFunction.CountIfs(s2.Range("A1:A" & son), s1.[A1], s2.Range("C1:C" & son), s1.[A2], s2.Range("B1:B" & son), s1.[A3]) = 0 Then
    MsgBox "Aranan verilere uygun kayıt bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Set con = VBA.CreateObject("adodb.Connection")
    
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
        
    sorgu = "select TARİH,Vardiya,işyeri,[Direkt İşç],[Kayıp Tip Kodu],[Kayıp Detay Tanım],[DURUŞ SINIFI] " & _
      "from[Duruşlar$A1:F" & son & "] where [TARİH] = " & s1.[A1] * 1 & " and [işyeri] = '" & s1.[A2] & "' and [Vardiya] = " & s1.[A3]
    Set rs = con.Execute(sorgu)
    
    [E2].CopyFromRecordset rs
    
    MsgBox "İşlem Tamamlandı"
End If
End Sub

 

[Merhum İdris SERDAR]

merhaba, örnekleri denedim ama yine yapamadım. anlamadım hata nerde. dosya ektedir. kriterleri de rapor sayfasında belirttim.

şimdiden elinize sağlık teşekkür ederim.

Dosyanızı başka bir bakış açısı ile düzenledim.

Table - Pivot Table ve Slicer uygulamaları kullanılmıştır.

.

 

[Erdem Akdemir]

@yusuf bey tablo adı F sütunu ile değil G sütunu ile bitmeli. Ayrıca tabloda başlıklar ilk satırda , tanımlama yapılmasınıa gerek yok.

 

[YUSUF44]

Sayın @Erdem_34 'ün uyarısıyla kodun son hali şöyle oldu ve düzgün bir şekilde çalışıyor:

Sub grafiksorgu()
Dim son As Long
Set s1 = Sheets("Rapor")
Set s2 = Sheets("Duruşlar")
eski = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "E").End(3).Row)
s1.Activate
s1.Range("E2:K" & eski).ClearContents
son = s2.Cells(Rows.Count, "A").End(xlUp).Row

If WorksheetFunction.CountIfs(s2.Range("A1:A" & son), s1.[A1], s2.Range("C1:C" & son), s1.[A2], s2.Range("B1:B" & son), s1.[A3]) = 0 Then
    MsgBox "Aranan verilere uygun kayıt bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Set con = VBA.CreateObject("adodb.Connection")
    
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
        
    sorgu = "select TARİH,Vardiya,işyeri,[Direkt İşç],[Kayıp Tip Kodu],[Kayıp Detay Tanım],[DURUŞ SINIFI] " & _
      "from[Duruşlar$] where [TARİH] = " & s1.[A1] * 1 & " and [işyeri] = '" & s1.[A2] & "' and [Vardiya] = " & s1.[A3]
    Set rs = con.Execute(sorgu)
    
    [E2].CopyFromRecordset rs
    
    MsgBox "İşlem Tamamlandı"
End If
End Sub

 

[hmtstc]

arkadaşlar çok sağolun, elinize sağlık mükemmel oldu.

Yusuf hocam son bir ricam olacak, eklemeyi atlamışım ben. yapmaya çalıştım ama sıralamayı beceremedim.

sondaki DURUŞ SINIFI yazan kısma da kriter eklemek istiyorum.

Duruş sınıfı "Plansız Duruş" olanlar gelsin tabloya sadece. planlılar gelmesin.

rica etsem yardımcı olur musunuz ?

 

[YUSUF44]

Şöyle olabilir:

sorgu = "select TARİH,Vardiya,işyeri,[Direkt İşç],[Kayıp Tip Kodu],[Kayıp Detay Tanım],[DURUŞ SINIFI] " & _
"from[Duruşlar$] where [TARİH] = " & s1.[A1] * 1 & " and [işyeri] = '" & s1.[A2] & "' and [Vardiya] = " & s1.[A3] & " and [DURUŞ SINIFI] = 'Plansız Duruş'"

 

[hmtstc]

Şöyle olabilir:

sorgu = "select TARİH,Vardiya,işyeri,[Direkt İşç],[Kayıp Tip Kodu],[Kayıp Detay Tanım],[DURUŞ SINIFI] " & _
"from[Duruşlar$] where [TARİH] = " & s1.[A1] * 1 & " and [işyeri] = '" & s1.[A2] & "' and [Vardiya] = " & s1.[A3] & " and [DURUŞ SINIFI] = 'Plansız Duruş'"

burada köşeli parantez var bazılarında bazılarında yok. köşeli parantezin manası ne oluyor hocam ?

 

[YUSUF44]

Başlık adlarında boşluk varsa köşeli parantez içine yazılması gerekiyor. From'dan sonraki kısımda boşluk olmayanlarda da var ama bu zorunlu mu bilmiyorum, öyle gördüğüm için öyle kullanıyorum. Diğer türlü denemedim.