Dizi olayı ile kod aşağıda abey.
Private Sub ComboBox1_Change()
Const Ekleme As String = "|ÞABLON|Sayfa1|liste|"
Dim syf As Worksheet
Dim arr, say As Integer
ReDim arr(1 To Worksheets.Count)
For Each syf In Worksheets
If InStr(1, Ekleme, "|" & syf.Name & "|", 1) = 0 Then
If LCase(syf.Name) Like LCase(Me.ComboBox1.Value) & "*" Then
say = say + 1
ReDim Preserve arr(1 To say)
arr(say) = syf.Name
End If
End If
Next
Me.ListBox1.Clear
If say > 0 Then Me.ListBox1.List = arr
If Me.ComboBox1.Value = Empty Then Me.ListBox1.Clear
Set syf = Nothing
Erase arr
End Sub
@
berduş hocam yinede yazayım C sürücüsüne Yedek adında yaedekleme yapılıyor excelin kapanma olayına yazmışlar aklınızda olsun.
amacım
sadece listbox'a recordsetten veri almak olduğu için diğer kodları sildim, excele TmpSilme adlı yeni bir sayfa ekledim
Option Compare Text
Const Ekleme As String = "|ŞABLON|Sayfa1|liste|TmpSilme|"
Dim Sql As String
Dim Cn As Object
Dim Rs As Object
Private 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
If InStr(1, Ekleme, "|" & syf.Name & "|", 1) = 0 Then
TmpVr.Range("a" & Hcr) = syf.Name
Hcr = Hcr + 1
End If
Next syf
Set Cn = CreateObject("Adodb.Connection")
Cn.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""
Cn.Open
SQL = "select * from [TmpSilme$A:A] where [F1]<>'' order by [F1]"
Set Rs = CreateObject("adodb.recordset")
Rs.Open SQL, Cn, 3, 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
'With Me.ListBox1
' .ColumnCount = Rs.Fields.Count
' .Column = Rs.GetRows
'' .ColumnHeads = True
'End With
Rs.Close
Set Rs = Nothing
End Sub
dizi kullanmayı da denedim, diziye değeri recordsetten alıp listeye eklemeyi arr ile yaptım olmadı.
Çok teşekkürler Hocalarım ellerinize sağlık.
Hocalarım mesaj 27 deki kodu uygulayabildim. 28 mesajdaki kodlarda uygulanması gerekiyorsa eklediğim dosyaya uygularmısınız. Kalması gereken kodları silmeden.
Kodu alttaki gib yaptım çalıştı.
ComboBox1.Column = Rs.GetRows
olunca çalışmıyor onada bakacağım.
Private 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
If InStr(1, Ekleme, "|" & syf.Name & "|", 1) = 0 Then
TmpVr.Range("a" & Hcr) = syf.Name
Hcr = Hcr + 1
End If
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 * 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
With Me.ListBox1
.ColumnCount = Rs.Fields.Count
.Column = Rs.GetRows
' .ColumnHeads = True
End With
Rs.Close
Set Rs = Nothing
End Sub
Bende de tam tersi oluyor)
Buda çalışan hali.Önce recordset ile listboxa alındı recordset kapatılp tekrar açıldı ve comboya alındı veriler.
Private 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
If InStr(1, Ekleme, "|" & syf.Name & "|", 1) = 0 Then
TmpVr.Range("a" & Hcr) = syf.Name
Hcr = Hcr + 1
End If
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 * 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
With Me.ListBox1
.ColumnCount = Rs.Fields.Count
.Column = Rs.GetRows
' .ColumnHeads = True
End With
Rs.Close
Rs.Open SQL, Cn, 1, 1
ComboBox1.Column = Rs.GetRows
Rs.Close
Cn.Close
Set Rs = Nothing
Set Cn = Nothing
End Sub
Böylede oluyor önemli olan recordset kapatmak combo başta yada sonda olması şart değil.
Private 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
If InStr(1, Ekleme, "|" & syf.Name & "|", 1) = 0 Then
TmpVr.Range("a" & Hcr) = syf.Name
Hcr = Hcr + 1
End If
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 * 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
' .ColumnHeads = True
End With
Rs.Close
Cn.Close
Set Rs = Nothing
Set Cn = Nothing
End Sub