referanslara Activex Data Object eklemeye de gerek kalmadı
form başına eklenecek kodlar
Option Compare Text
Const Ekleme As String = "'ŞABLON','Sayfa1','liste','TmpSilme'"
Dim Sql As String
Dim Cn As Object
Dim Rs As Object
UserForm_Initialize olayının kodları OpenSchema yöntemi işi karıştırdığı için sildimPrivate Sub UserForm_Initialize()
Dim syf, TmpVr As Worksheet, k As Byte
Set TmpVr = Sheets("TmpSilme")
TmpVr.Unprotect "4455"
TmpVr.Cells.Clear
Hcr = 1
For Each syf In Worksheets
TmpVr.Range("a" & Hcr) = syf.Name
Hcr = Hcr + 1
Next syf
Set Cn = CreateObject("Adodb.Connection")
Set Rs = CreateObject("adodb.recordset")
Cn.Open "provider=Microsoft.ACE.OLEDB.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""
SQL = "select [F1] from [TmpSilme$A:A] where not isnull(f1) and [F1] not in(" & Ekleme & ")"
Rs.Open SQL, Cn, 1, 1
TmpVr.Range("B1").CopyFromRecordset Rs
Rs.Close
SQL = "select [F1] from [TmpSilme$B:B] where not isnull(f1) order by [F1]"
Rs.Open SQL, Cn, 1, 1
TmpVr.Range("A:A").Clear
TmpVr.Range("A1").CopyFromRecordset Rs
Rs.Close
SQL = "select [F1] from [TmpSilme$a:a] where not isnull(f1) order by [F1]"
Rs.Open SQL, Cn, 1, 1
' Eğer Hiç Kayıt Yoksa
If Rs.RecordCount = 0 Then
Rs.Close
Set Rs = Nothing
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
Exit Sub
End If
ComboBox1.Column = Rs.GetRows
Rs.Close
Rs.Open SQL, Cn, 1, 1
With Me.ListBox1
.ColumnCount = Rs.Fields.Count
.Column = Rs.GetRows
End With
Rs.Close
Cn.Close
Set Rs = Nothing
Set Cn = Nothing
End Sub
bu da açılır kutu değiştiğinde olayıPrivate Sub ComboBox1_Change()
Dim syf As Worksheet, k As Byte
If Len(Me.ComboBox1.Value & "") = 0 Then
Sql = "select [F1] from [TmpSilme$A:A] where not isnull(f1)"
Else
Sql = "select [F1] from [TmpSilme$A:A] where not isnull(f1) and [f1] like '%" & Me.ComboBox1.Text & "%' order by [F1]"
End If
Set Cn = CreateObject("Adodb.Connection")
Set Rs = CreateObject("adodb.recordset")
Cn.Open "provider=Microsoft.ACE.OLEDB.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""
Rs.Open SQL, Cn, 1, 1 '
' Eğer Hiç Kayıt Yoksa
If Rs.RecordCount = 0 Then
Rs.Close
Cn.Close
Set Rs = Nothing
Set Cn = Nothing
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
Exit Sub
End If
ComboBox1.Column = Rs.GetRows
Rs.Close
Rs.Open SQL, Cn, 1, 1
With Me.ListBox1
.ColumnCount = Rs.Fields.Count
.Column = Rs.GetRows
End With
Rs.Close
Cn.Close
Set Rs = Nothing
Set Cn = Nothing
End Sub