Aynı kitaptan Adobb conn ile combo ve listwieve veri çekme?

H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Excel açlışma kitabımın data sayfasının B5:I50000 aralığındaki
Başlıklar____ExcHuc__Useformda yerleşeceği nesne
AD_SOYAD_______C4____ Lwv_AdSoyad
BYIL___________F4____ Cmb_Byil
MYIL___________G4____ Cmb_Myil
GIDER_TURU_____H4____ Cmb_GTur
MES_MER________I4____ Cmb_MMer


Şeklinde aşağıdaki koşullarda gelebilir mi?
Userform initalizede Bütçe yılı benzersiz olanlar Cmb_Byil nesnesine gelecek, 2008 yılı seçildi diyelim diğer combolorda alanlar kısıtlanacak ve 2008 bütçer yılında hangi mali yıllar için harcama yapılacaksa onlar gelecek. daha sonra seçili bütçe ve mali yıllar için hangi gider türlerinde harcama yapılmışsa onlar cmb_Gtur nesnesine gelecek, Cmb_MMer nesnesine ise seçili bütçe yılı, maliyet yılı ve gider türü aynı olanların masraf merkezinde ne varsa o gelecek.
Lwv_AdSoyad nesnesine ise seçili bütçe yılı, maliyet yılı ve gider türü, masraf merkezi aynı olanların Ad Soyad kısmında ne varsa o gelecek.

aşağıda olan örnek birbirine bağlı 3 combolu ve başka bir çalışma kitabından combolara değer alan örnektir. Ancak şu ank isteğimde 4 combo ve 1 listwiev olduğu için işin içinden çıkamadım.

Nihai amacım örneğin 2008 by, 2008 my, Personel Gider Türünün, Daimi Masraf merkezinde yer alan kişileri Listwiev nesnesine raporlayıp, seçili olanları otomotik süz, yazdır demek.

Kod: 
[FONT=Courier New]Private Sub UserForm_Initialize()[/FONT]
 
 
[FONT=Courier New]On Error Resume Next[/FONT]
[FONT=Courier New]Dim Baglanti As ADODB.Connection[/FONT]
[FONT=Courier New]Dim Kayit1 As ADODB.Recordset[/FONT]
[FONT=Courier New]Dim SQLStr, Kaynak As String[/FONT]
[FONT=Courier New]Dim i, bas As Integer[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Kaynak = Application.ThisWorkbook.Path & "\" & "vtmahbirimler.xls"[/FONT]
[FONT=Courier New]If Dir(Kaynak) = "" Then[/FONT]
[FONT=Courier New]MsgBox Kaynak & " " & Chr(10) & " Dosyası Bulunamadı.", vbInformation, "Bilgi"[/FONT]
[FONT=Courier New]Exit Sub[/FONT]
[FONT=Courier New]End If[/FONT]
[FONT=Courier New]SQLStr = "SELECT DISTINCT il FROM [ilveilce$]"[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Set Baglanti = CreateObject("ADODB.Connection")[/FONT]
[FONT=Courier New] With Baglanti[/FONT]
[FONT=Courier New]     .Provider = "Microsoft.Jet.OLEDB.4.0"[/FONT]
[FONT=Courier New]     .Properties("Extended Properties").Value = "Excel 8.0"[/FONT]
[FONT=Courier New]     .Properties("Data Source").Value = Kaynak[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .Mode = adModeReadWrite[/FONT]
[FONT=Courier New]     .CommandTimeout = 60[/FONT]
[FONT=Courier New]     '.Properties("User ID") = vbNullString[/FONT]
[FONT=Courier New]     '.Properties("Password") = vbNullString[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
 
[FONT=Courier New] Set Kayit1 = CreateObject("ADODB.Recordset")[/FONT]
[FONT=Courier New] With Kayit1[/FONT]
[FONT=Courier New]     .ActiveConnection = Baglanti[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .CursorType = adOpenKeyset[/FONT]
[FONT=Courier New]     .LockType = adLockOptimistic[/FONT]
[FONT=Courier New]     .Source = SQLStr[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]     Kayit1.MoveFirst[/FONT]
[FONT=Courier New]     ComboBox1.Clear[/FONT]
[FONT=Courier New]         For i = 1 To Kayit1.RecordCount[/FONT]
[FONT=Courier New]            ComboBox1.AddItem Kayit1.Fields("il")[/FONT]
[FONT=Courier New]            Kayit1.MoveNext[/FONT]
[FONT=Courier New]         Next i[/FONT]
[FONT=Courier New]     Kayit1.MoveFirst[/FONT]
[FONT=Courier New]     ComboBox1.ListIndex = 0[/FONT]
[FONT=Courier New]If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close[/FONT]
[FONT=Courier New]Set Kayit1 = Nothing[/FONT]
[FONT=Courier New]If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close[/FONT]
[FONT=Courier New]Set Baglanti = Nothing[/FONT]
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub UserForm_Terminate()[/FONT]
[FONT=Courier New] 'THIS MUST BE CALLED OR WE HAVE A PROBLEM WITH THE CALLBACK[/FONT]
[FONT=Courier New] UnHookWheel[/FONT]
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub ComboBox1_Change()[/FONT]
[FONT=Courier New]On Error Resume Next[/FONT]
[FONT=Courier New]Dim Baglanti As ADODB.Connection[/FONT]
[FONT=Courier New]Dim Kayit1 As ADODB.Recordset[/FONT]
[FONT=Courier New]Dim SQLStr, Kaynak As String[/FONT]
[FONT=Courier New]Dim i, bas As Integer[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Kaynak = Application.ThisWorkbook.Path & "\" & "vtmahbirimler.xls"[/FONT]
[FONT=Courier New]If Dir(Kaynak) = "" Then[/FONT]
[FONT=Courier New]MsgBox Kaynak & " " & Chr(10) & " Dosyası Bulunamadı.", vbInformation, "Bilgi"[/FONT]
[FONT=Courier New]Exit Sub[/FONT]
[FONT=Courier New]End If[/FONT]
[FONT=Courier New]SQLStr = "SELECT DISTINCT il, ilce FROM [ilveilce$] WHERE il=" & "'" & ComboBox1.Value & "'"[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Set Baglanti = CreateObject("ADODB.Connection")[/FONT]
[FONT=Courier New] With Baglanti[/FONT]
[FONT=Courier New]     .Provider = "Microsoft.Jet.OLEDB.4.0"[/FONT]
[FONT=Courier New]     .Properties("Extended Properties").Value = "Excel 8.0"[/FONT]
[FONT=Courier New]     .Properties("Data Source").Value = Kaynak[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .Mode = adModeReadWrite[/FONT]
[FONT=Courier New]     .CommandTimeout = 60[/FONT]
[FONT=Courier New]     '.Properties("User ID") = vbNullString[/FONT]
[FONT=Courier New]     '.Properties("Password") = vbNullString[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
 
[FONT=Courier New] Set Kayit1 = CreateObject("ADODB.Recordset")[/FONT]
[FONT=Courier New] With Kayit1[/FONT]
[FONT=Courier New]     .ActiveConnection = Baglanti[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .CursorType = adOpenKeyset[/FONT]
[FONT=Courier New]     .LockType = adLockOptimistic[/FONT]
[FONT=Courier New]     .Source = SQLStr[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]     Kayit1.MoveFirst[/FONT]
[FONT=Courier New]     ComboBox2.Clear[/FONT]
[FONT=Courier New]         For i = 1 To Kayit1.RecordCount[/FONT]
[FONT=Courier New]            ComboBox2.AddItem Kayit1.Fields("ilce")[/FONT]
[FONT=Courier New]            Kayit1.MoveNext[/FONT]
[FONT=Courier New]         Next i[/FONT]
[FONT=Courier New]     Kayit1.MoveFirst[/FONT]
[FONT=Courier New]     ComboBox2.ListIndex = 0[/FONT]
[FONT=Courier New]If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close[/FONT]
[FONT=Courier New]Set Kayit1 = Nothing[/FONT]
[FONT=Courier New]If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close[/FONT]
[FONT=Courier New]Set Baglanti = Nothing[/FONT]
[FONT=Courier New]End Sub[/FONT]
[FONT=Courier New]Private Sub ComboBox2_Change()[/FONT]
[FONT=Courier New]On Error Resume Next[/FONT]
[FONT=Courier New]Dim Baglanti As ADODB.Connection[/FONT]
[FONT=Courier New]Dim Kayit1 As ADODB.Recordset[/FONT]
[FONT=Courier New]Dim SQLStr, Kaynak As String[/FONT]
[FONT=Courier New]Dim i, bas As Integer[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Kaynak = Application.ThisWorkbook.Path & "\" & "vtmahbirimler.xls"[/FONT]
[FONT=Courier New]If Dir(Kaynak) = "" Then[/FONT]
[FONT=Courier New]MsgBox Kaynak & " " & Chr(10) & " Dosyası Bulunamadı.", vbInformation, "Bilgi"[/FONT]
[FONT=Courier New]Exit Sub[/FONT]
[FONT=Courier New]End If[/FONT]
[FONT=Courier New]SQLStr = "SELECT DISTINCT il, ilce,mahkoy FROM [ilveilce$] WHERE il=" & "'" & ComboBox1.Value & "'" & "AND ilce=" & "'" & ComboBox2.Value & "'"[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Set Baglanti = CreateObject("ADODB.Connection")[/FONT]
[FONT=Courier New] With Baglanti[/FONT]
[FONT=Courier New]     .Provider = "Microsoft.Jet.OLEDB.4.0"[/FONT]
[FONT=Courier New]     .Properties("Extended Properties").Value = "Excel 8.0"[/FONT]
[FONT=Courier New]     .Properties("Data Source").Value = Kaynak[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .Mode = adModeReadWrite[/FONT]
[FONT=Courier New]     .CommandTimeout = 60[/FONT]
[FONT=Courier New]     '.Properties("User ID") = vbNullString[/FONT]
[FONT=Courier New]     '.Properties("Password") = vbNullString[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New]    Set Kayit1 = CreateObject("ADODB.Recordset")[/FONT]
[FONT=Courier New] With Kayit1[/FONT]
[FONT=Courier New]     .ActiveConnection = Baglanti[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .CursorType = adOpenKeyset[/FONT]
[FONT=Courier New]     .LockType = adLockOptimistic[/FONT]
[FONT=Courier New]     .Source = SQLStr[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]    Kayit1.MoveFirst[/FONT]
[FONT=Courier New]    ComboBox3.Clear[/FONT]
[FONT=Courier New]         For i = 1 To Kayit1.RecordCount[/FONT]
[FONT=Courier New]            ComboBox3.AddItem Kayit1.Fields("mahkoy")[/FONT]
[FONT=Courier New]            Kayit1.MoveNext[/FONT]
[FONT=Courier New]         Next i[/FONT]
[FONT=Courier New]    Kayit1.MoveFirst[/FONT]
[FONT=Courier New]    If Me.ComboBox1.Value <> "" Then ComboBox3.ListIndex = 0[/FONT]
[FONT=Courier New]If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close[/FONT]
[FONT=Courier New]Set Kayit1 = Nothing[/FONT]
[FONT=Courier New]If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close[/FONT]
[FONT=Courier New]Set Baglanti = Nothing[/FONT]
[FONT=Courier New]End Sub[/FONT]
 
 
[FONT=Courier New]Private Sub ComboBox3_Change()[/FONT]
[FONT=Courier New]On Error Resume Next[/FONT]
[FONT=Courier New]Dim Baglanti As ADODB.Connection[/FONT]
[FONT=Courier New]Dim Kayit1 As ADODB.Recordset[/FONT]
[FONT=Courier New]Dim SQLStr, Kaynak As String[/FONT]
[FONT=Courier New]Dim i, bas As Integer[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Kaynak = Application.ThisWorkbook.Path & "\" & "vtmahbirimler.xls"[/FONT]
[FONT=Courier New]If Dir(Kaynak) = "" Then[/FONT]
[FONT=Courier New]MsgBox Kaynak & " " & Chr(10) & " Dosyası Bulunamadı.", vbInformation, "Bilgi"[/FONT]
[FONT=Courier New]Exit Sub[/FONT]
[FONT=Courier New]End If[/FONT]
[FONT=Courier New]SQLStr = "SELECT DISTINCT il, ilce,mahkoy,plaka,postakod,telkod FROM [ilveilce$] WHERE il=" & "'" & ComboBox1.Value & "'" & "AND ilce=" & "'" & ComboBox2.Value & "'" & "AND mahkoy=" & "'" & ComboBox3.Value & "'"[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]Set Baglanti = CreateObject("ADODB.Connection")[/FONT]
[FONT=Courier New] With Baglanti[/FONT]
[FONT=Courier New]     .Provider = "Microsoft.Jet.OLEDB.4.0"[/FONT]
[FONT=Courier New]     .Properties("Extended Properties").Value = "Excel 8.0"[/FONT]
[FONT=Courier New]     .Properties("Data Source").Value = Kaynak[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .Mode = adModeReadWrite[/FONT]
[FONT=Courier New]     .CommandTimeout = 60[/FONT]
[FONT=Courier New]     '.Properties("User ID") = vbNullString[/FONT]
[FONT=Courier New]     '.Properties("Password") = vbNullString[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New]    Set Kayit1 = CreateObject("ADODB.Recordset")[/FONT]
[FONT=Courier New] With Kayit1[/FONT]
[FONT=Courier New]     .ActiveConnection = Baglanti[/FONT]
[FONT=Courier New]     .CursorLocation = adUseClient[/FONT]
[FONT=Courier New]     .CursorType = adOpenKeyset[/FONT]
[FONT=Courier New]     .LockType = adLockOptimistic[/FONT]
[FONT=Courier New]     .Source = SQLStr[/FONT]
[FONT=Courier New]     .Open[/FONT]
[FONT=Courier New] End With[/FONT]
[FONT=Courier New]'***********************************************************************[/FONT]
[FONT=Courier New]    Kayit1.MoveFirst[/FONT]
[FONT=Courier New]    Label6.Caption = Kayit1.Fields("plaka")[/FONT]
[FONT=Courier New]    Label5.Caption = Kayit1.Fields("postakod")[/FONT]
[FONT=Courier New]    Label8.Caption = Kayit1.Fields("telkod")[/FONT]
[FONT=Courier New]If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close[/FONT]
[FONT=Courier New]Set Kayit1 = Nothing[/FONT]
[FONT=Courier New]If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close[/FONT]
[FONT=Courier New]Set Baglanti = Nothing[/FONT]
[FONT=Courier New]End Sub[/FONT]
 
[FONT=Courier New]Private Sub CommandButton1_Click()[/FONT]
[FONT=Courier New]Unload Me[/FONT]
[FONT=Courier New]End Sub[/FONT]
 
Son düzenleme:
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
ben ilk denememi yaptım tür uyşmazlığı diyor.
Kod: 
'######################################################################################################////
Private Sub UserForm_Initialize()                                                                      '##'
'*\ Form denetimlerininin özelliklerini belirle                                                        '##'
    CommandButton2.Cancel = True                 'Userform üzerinde "ESC" ye basınca çıkışa izin ver.  '##'
    TextBox1 = 1:                       Cbx_AdSoyad.Caption = "Tüm  Sayfaları  Seç"                      '##'
    With Lvw_AdSoyad                                                                                     '##'
        .View = lvwReport:              .LabelEdit = lvwManual                                         '##'
        .CheckBoxes = True                                          'Her elemana CheckBox oluşturur.   '##'
        .ColumnHeaders.Clear:           .ListItems.Clear              'başlıkları ve öğeleri temizle   '##'
        .ColumnHeaders.Add , , "Adı Soyadı", 142                    'başlık ve genişliklerini ayarla     '##'
    End With   'Lvw_AdSoyad                                                                              '##'
'*\ Değişken tanımlama ve set etme                                                                     '##'
    Dim Wsh As WshNetwork:          Set Wsh = New WshNetwork                                           '##'
    adbKaynak = ThisWorkbook.FullName                                                                                '##'
    'SqlStr = "SELECT DISTINCT il FROM [ilveilce$A4:R65536]"
    Set obConn = CreateObject("ADODB.Connection")                                                       '||
        With obConn
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Properties("Extended Properties").Value = "Excel 8.0"
            .Properties("Data Source").Value = adbKaynak
            .CursorLocation = adUseClient
            .Mode = adModeReadWrite
            .CommandTimeout = 60
            '.Properties("User ID") = vbNullString
            '.Properties("Password") = vbNullString
            .Open
        End With 'obConn
    Set ObRcSt = CreateObject("ADODB.Recordset")
    SqlStr = "SELECT DISTINCT BYIL FROM [Data$A4:I65536]"
        With ObRcSt
            .ActiveConnection = obConn
            .CursorLocation = adUseClient
            .CursorType = adOpenKeyset
            .LockType = adLockOptimistic
            .Source = SqlStr
            .Open
            .MoveFirst
        End With
' '***********************************************************************
    'ObRcSt.MoveFirst
    cmb_BYil.Clear
        For i = 1 To ObRcSt.RecordCount
           cmb_BYil.AddItem i 'ObRcSt.Fields("BYIL")
           ObRcSt.MoveNext
        Next i
    ObRcSt.MoveFirst
    cmb_BYil.ListIndex = 0
If CBool(ObRcSt.State And adStateOpen) = True Then ObRcSt.Close
Set ObRcSt = Nothing
If CBool(obConn.State And adStateOpen) = True Then obConn.Close
Set obConn = Nothing
  
'Aktif Kitaptaki Sayfa Listesini Listbox1/Lvw_AdSoyad e alır                                             '##'
'    For i = 1 To ActiveWorkbook.Sheets.Count                                                           '##'
'        Lvw_AdSoyad.ListItems.Add , , Sheets(i).Name                                                     '##'
'    Next i                                                                                             '##'
'**\ Aktif Bilgisayardaki Yazıcı Listesini CmbYazici e alır                                            '##'
    With CmbYazici                                                                                     '##'
        For i = 1 To Wsh.EnumPrinterConnections.Count - 1 Step 2                                       '##'
            .AddItem Wsh.EnumPrinterConnections(i)                                                     '##'
        Next                                                                                           '##'
'**\ Varsayılan yazıcıyı Combo1e atar                                                                  '##'
        .Value = FncHsr_VarsayilanYazici()                                                             '##'
    End With 'CmbYazici                                                                                '##'
'*\ Değişkenleri ve değerlerini hafızadan silme                                                        '##'
Set Wsh = Nothing:                  i = 0                                                              '##'
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst