Bu Kodları Nasıl Kısaltırız

[programer]

Arkadaşlar merhaba Bir UserForm üzerinde 25 adet textbox var. Kodlardan tasarruf sağlamak istiyorum herbirine tek tek yazmaktansa bunun için alternatif olarak ne yapabiliriz.

Private Sub STK1_Change()
On Error Resume Next
Dim X As Integer
X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=STK1, LookIn:=xlValues).Row
STK1.Value = STK1
STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
End Sub

Private Sub STK1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If STK1 = "" Then Exit Sub
On Error Resume Next
X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=STK1, LookIn:=xlValues).Row
STK1.Value = STK1
STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
End Sub

Private Sub STK2_Change()
On Error Resume Next
Dim X As Integer
X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=STK2, LookIn:=xlValues).Row
STK2.Value = STK2
STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
End Sub

Private Sub STK2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If STK2 = "" Then Exit Sub
On Error Resume Next
X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=STK2, LookIn:=xlValues).Row
STK2.Value = STK2
STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
End Sub

 

[veyselemre]

Ezbere birşeyler yaptım çalışıp çalışmayacağını bilemem.

Private Sub STK1_Change()
    On Error Resume Next
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(ara(stk1), 3)
End Sub
Private Sub STK1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If stk1 = "" Then Exit Sub
    On Error Resume Next
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(ara(stk1), 3)
End Sub
Private Sub STK2_Change()
    On Error Resume Next
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(ara(stk2), 3)
End Sub
Private Sub STK2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If stk2 = "" Then Exit Sub
    On Error Resume Next
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(ara(stk2), 3)
End Sub
Function ara(bul As String) As Integer
    On Error Resume Next
    ara = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=bul, LookIn:=xlValues).Row
End Function

 

[programer]

Sayın veyselemre yardımınız için teşekkür ederim. Kodları her textbox için yazman gerekicek. Forumdan bulduğum bir class modül çalışmasını uyarlamaya çalıştım ama yazdığım kodlar çalışmadı. textboxların içine veri yazdığım zaman veriyi Stk_Stk_Tnt sayfasında arayıp karşılığını STKGNLACK textbox'una gelmesi gerekiyor.


Bunlar UserForm'un Iniztalize kısmındaki kodlar

ReDim Preserve cmb(25)
For a = 1 To 25
Set cmb(a).cmb= Controls("STK" & a)
Next

Bunlarda Class modülün kodları

Public WithEvents cmb As MSForms.TextBox

Private Sub cmb_Change()
On Error Resume Next
 If Satinalma_Giris_Frm.Controls("STK") = "" Then
    X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=cmb.Value, LookIn:=xlValues).Row
    Satinalma_Giris_Frm.Controls("STK").Value = Satinalma_Giris_Frm.Controls("STK")
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
 End If
End Sub

Private Sub cmb_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
Satinalma_Giris_Frm.Controls("" & [hz1]).BackColor = vbWhite
 If Satinalma_Giris_Frm.Controls("STK") = "" Then
    X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=cmb.Value, LookIn:=xlValues).Row
    Satinalma_Giris_Frm.Controls("STK").Value = Satinalma_Giris_Frm.Controls("STK")
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
 End If
End Sub

Private Sub cmb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
cmb.BackColor = vbYellow
[hz1] = cmb.Name
End Sub

Private Sub cmb_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Satinalma_Giris_Frm.Controls("" & [hz1]).BackColor = vbWhite
End Sub

Private Sub cmb_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
cmb.BackColor = vbYellow
[hz1] = cmb.Name
End Sub

 

[programer]

Arkadaşlar kodları aşağıdaki gibi tekrar düzenledim ama bir sonuç elde edemedim. 25 adet textbox var. bunlar için class modul oluşturdum textbox ların herhangibirine veri girdiğim zaman bu veriyi Stk_Stk_Tnt sayfasında B sütünunda arayacak bulduğu zaman C sütünündaki veriyi STKGNLACK textbox una yazacak.

Public WithEvents cmb As MSForms.TextBox

Private Sub cmb_Change()
On Error Resume Next
Dim X As Integer
   X = Sheets("Stk_Stk_Tnt").Range("B:B").Cells.Find(what:=cmb.Value, LookIn:=xlValues).Row
    cmb.Value = cmb
    STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(X, 3)
End Sub

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

 

[programer]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Sayın COST_CONTROL yardımınız içi teşekkür ederim tam istediğim bigi olmuş. Yalnız şöyle bir problemle karşılaştım 25 adet texbox'u fazla yer kaplamasın diye bir Frame içine aldım. TextBoxlar frame içindeyken kod çalışmıyor. TexBox ları frameden dışarı çıkardığım zaman kodlar gayet güze çalışıyor. Bu sorunu nasıl düzelte biliriz. Örnek dosya ekte.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

 

[veyselemre]

Sayın COST_CONTROL'ün güzel cevabına bir ek yaparsak, daha kullanışlı olur, Textboxlar a girişte de çalışırsa, textboxlar arasında gezerkende alttaki bilgi güncellenir. Class moduldeki kodları aşağıdaki gibi düzeltebilirsiniz.http://www.excel.web.tr/member.php?u=3553

Public WithEvents Txt As MSForms.TextBox
Private Sub Txt_Change()
    If Txt <> "" Then Call Calis(Txt)
End Sub
Private Sub Txt_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Txt <> "" Then Call Calis(Txt)
End Sub
Private Sub Calis(Ara)
    On Error Resume Next
    Set Bul = Sheets("Stk_Stk_Tnt").Columns(2).Find(Ara, LookAt:=xlWhole)
    If Not Bul Is Nothing Then
        UserForm1.STKGNLACK = Sheets("Stk_Stk_Tnt").Cells(Bul.Row, 3)
    Else
        UserForm1.STKGNLACK = ""
    End If
End Sub

 

[programer]

Sayın COST_CONTROL ve Sayın veyselemre cevaplarınız için çok teşekkür ederim elinize sağlık tam istediğim gibi oldu.