Kapalı Dosyadan Userform üzerindeki TextBoxlara veri getirmek.

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar Userform üzerinde bulunan TextBox12'ye yazmış olduğum sicil numarasına göre "D:\Belgelerim\Personel\PERSONEL LİSTESİ.xlsm" burada bulunan personel listesi dosyasındaki LİSTE ve TÜM sayfamda bulunan K sütunundaki IBAN ile karşılaştırıp TextBox17 ya yazmasını Ad Soyadını TextBox16 ye getirmesini istiyorum. Teşekkürler
Siteden Şöyle bir şey buldum ama uyarlayamadım,

Private Sub CommandButton11_Click()
Dim s1 As Worksheet, syf As Variant
Dim con, rs
Dim m As Long, a As Long
Set s1 = ActiveSheet
syf = Array("LİSTE$", "TÜM$")
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("adodb.recordset")
s1.Range("C3" & Rows.Count).ClearContents
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & "D:\Belgelerim\Personel\PERSONEL LİSTESİ.xlsm" & ";Extended Properties = ""Excel 12.0 Macro;HDR=Yes"";"
For m = 0 To UBound(syf)
For a = 3 To s1.Cells(Rows.Count, "B").End(3).Row
If Trim(s1.Cells(a, "C").Value) <> "" Or Trim(s1.Cells(a, "D").Value) <> "" Then GoTo 10
rs.Open "select * from [" & syf(m) & "] where Sicili=" & s1.Cells(a, "B").Value & ";", con, 1, 3
If rs.RecordCount > 0 Then
s1.Cells(a, "C").Value = Trim(rs("Adı").Value & " " & rs("Soyadı").Value) 'BURDAKİ C sütunu Userformda TextBox16
s1.Cells(a, "D").Value = Trim(rs("IBAN").Value) ' BURDAKİ D sütunu Userformda TextBox17
If Trim(s1.Cells(a, "C").Value) = "" Then s1.Cells(a, "C").Value = "PERSONEL ADI YOK"
If Trim(s1.Cells(a, "D").Value) = "" Then s1.Cells(a, "D") = "IBAN BULUNAMADI"
Else
If m = 1 Then
If Trim(s1.Cells(a, "C").Value) = "" Then s1.Cells(a, "C").Value = "PERSONEL ADI YOK"
If Trim(s1.Cells(a, "D").Value) = "" Then s1.Cells(a, "D") = "IBAN BULUNAMADI"
End If
End If
rs.Close
10:
Next a
Next
con.Close


End Sub

 

[Hacı Bayram ÖZKAN]

öRNEK Dosyada ekliyorum.

 

[Hacı Bayram ÖZKAN]

Tekrar Merhaba arkadaşlar; formda arayarak buldum şu kodla dosyam çalışıyor. Kod Şu:

Dim melek As Object

Private Sub TextBox12_Change()
On Error Resume Next
TextBox16 = ""
TextBox17 = ""
TextBox18 = ""
' TextBox6 = ""
If Err = 0 Then
TextBox16 = melek(CStr(TextBox12))(0)
TextBox17 = melek(CStr(TextBox12))(1)
TextBox18 = melek(CStr(TextBox12))(2)
'TextBox6 = melek(CStr(TextBox12))(3)
End If
On Error GoTo 0

End Sub

Private Sub UserForm_Initialize()
Set melek = CreateObject("scripting.dictionary")
' yol = ThisWorkbook.Path

yol = "D:\Belgelerim\Personel"
dosya = "PERSONEL LİSTESİ.xlsm"
Application.ScreenUpdating = False
GetObject (yol & "\" & dosya)
Set s1 = Workbooks(dosya).Sheets("LİSTE")
son = s1.Cells(Rows.Count, 4).End(3).Row
a = s1.Range("B2:K20" & son).Value
For i = 1 To UBound(a)
melek(CStr(a(i, 1))) = Array(a(i, 2), a(i, 3), a(i, 6), a(i, 5))
Next i
Workbooks(dosya).Close
End Sub

Ancak Tek sorun şu; kodu çalışınca kapalı olan PERSONEL LİSTESİ dosyasının VBA'sını açıyor, bir nevi bu kapalı dosyayı açıyor, nereyi düzeltmem lazım yardımcı olursanız sevinirim Çalışan dosya ekte Teşekkürler.

 

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar; Kodları çalıştırdım, tek sorun, sicil ve soyada göre seçimini nasıl yapabilirim.

If OptionButton1 = True Then

melek(CStr(a(i, 1))) = Array(a(i, 2), a(i, 3), a(i, 6), a(i, 5)) ' Sicil göre ara
Else
melek(CStr(a(i, 3))) = Array(a(i, 2), a(i, 3), a(i, 6), a(i, 5)) ' Soyada göre ara

End If

Böyle yaptım, olmadı sadece soyada göre aradı. Nasıl düzeltirim. Tekrar yeni dosyayı ekledim. Teşekkürler.

 

[Hacı Bayram ÖZKAN]

Selamün Aleyküm arkadaşlar 4 dolu mesajıma bakar mısınız? Teşekkürler.

 

[PLİNT]

Aleyküm selam
"personel ara.xls" dosyasındaki "userform1" kodlarını tümüyle aşağıdakilerle değiştirip deneyiniz

Public ls As Variant


Private Sub TextBox12_Change()
Dim x As Long, a As Long
    TextBox16 = ""
    TextBox17 = ""
    TextBox18 = ""
If IsNumeric(Trim(TextBox12.Text)) = True And Len(TextBox12) = 6 Then: x = 1
If IsNumeric(Trim(TextBox12.Text)) = False And Len(TextBox12) >= 2 Then x = 3
If x <> 0 Then
For a = LBound(ls, 2) To UBound(ls, 2)
If TextBox12.Text = ls(x, a) And TextBox18 = "" Then
TextBox16 = ls(2, a)
TextBox17 = ls(3, a)
TextBox18 = ls(4, a)
Else
If TextBox18 <> "" And Trim(TextBox12.Text) = ls(x, a) Then
s = s & ls(2, a) & " " & ls(3, a) & " " & ls(4, a)
If IsEmpty(s) = False Then s = s & vbCrLf
End If
End If
 Next
If IsEmpty(s) = False Then MsgBox "Soyadı Aynı olanlar var" & vbCrLf & s
End If
End Sub

Private Sub UserForm_Initialize()
Dim a As Long, dosyayolu As String, sorgu As String, con As Object, rs
ReDim ls(1 To 4, 1 To 1)
    'Application.ScreenUpdating = False
dosyayolu = "D:\Belgelerim\Personel\PERSONEL LİSTESİ.xlsm"
Set con = VBA.CreateObject("adodb.Connection")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
dosyayolu & ";Extended Properties = ""Excel 12.0 Macro;HDR=yes"";"
sorgu = "select Sicili,Adı,Soyadı,[Tc Kimlik No] from[LİSTE$] where sicili is not null "
 Set rs = con.Execute(sorgu)
Do Until rs.EOF
a = a + 1
ReDim Preserve ls(1 To 4, 1 To a)
ls(1, a) = rs!Sicili
ls(2, a) = rs!Adı
ls(3, a) = rs!Soyadı
ls(4, a) = rs![Tc Kimlik No]
rs.MoveNext
Loop
con.Close
End Sub

 

[Hacı Bayram ÖZKAN]

Teşekkür ederim Sayın PLİNT, dua ile kalın.....