• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

UserForm Üzerinde Bul Komutu ve Listbox Hizalama

T

tete58

Katılım
18 Haziran 2010
Mesajlar
72
Excel Vers. ve Dili
office2003
Arkadaşlar uzun süredir araştırıyorum lakin bulamadım verinin bir bölümünü yazarak arama yapılmasıyla ilgili konuyu ekli dosyada özetledim Yardımcı olacak arkadaşlara teşekkür ederim
 

Ekli dosyalar

Userform içindeki kodları aşağıdakiler ile değiştirin.
Kod: 
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then Call bul_59(TextBox2)
End Sub

Private Sub CommandButton2_Click()
Sheets("VERİ").Range("C4").Value = TextBox1
Sheets("VERİ").Range("C6").Value = TextBox3
Sheets("VERİ").Range("E4").Value = TextBox4
Sheets("VERİ").Range("C5").Value = TextBox5
Sheets("VERİ").Range("E5").Value = TextBox6

Unload UserForm1
End Sub

Private Sub Label3_Click()

End Sub

Private Sub ListBox1_Click()
If ListBox1.ColumnCount = 0 Then Exit Sub
TextBox1.Text = ListBox1.Column(0)
TextBox3.Text = ListBox1.Column(1)
TextBox4.Text = ListBox1.Column(2)
TextBox5.Text = ListBox1.Column(3)
TextBox6.Text = ListBox1.Column(4)
End Sub

Private Sub TextBox2_Change()
TextBox2 = Evaluate("=upper(""" & TextBox2 & """)")
End Sub

Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 5
[color=red]ListBox1.ColumnWidths = "80;150;80;80;60"[/color]
OptionButton1.Value = True
TextBox2.SetFocus
End Sub
Private Sub bul_59(ByVal txt As Control)
Dim sut As String, k As Range, adr As String, myarr(), a As Long
Dim sat As Long, deg
ListBox1.Clear
If txt.Text = "" Then Exit Sub
If txt.Name = "TextBox2" Then
    sut = "B"
    deg = txt.Text
   End If
sat = Sheets("Data").Cells(65536, sut).End(xlUp).Row
ReDim myarr(1 To 5, 1 To 65536)
Set k = Sheets("Data").Range(sut & "2:" & sut & sat). _
Find([color=red]deg & "*"[/color], , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        a = a + 1
        myarr(1, a) = Sheets("Data").Cells(k.Row, "B").Value
        myarr(2, a) = Sheets("Data").Cells(k.Row, "C").Value
        myarr(3, a) = Sheets("Data").Cells(k.Row, "D").Value
        myarr(4, a) = Sheets("Data").Cells(k.Row, "E").Value
        myarr(5, a) = Sheets("Data").Cells(k.Row, "F").Value
        Set k = Sheets("Data").Range(sut & "2:" & sut & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
    ReDim Preserve myarr(1 To 5, 1 To a)
    ListBox1.Column = myarr
End If
End Sub
 
hamitcan' Alıntı:
Userform içindeki kodları aşağıdakiler ile değiştirin.
Kod: 
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then Call bul_59(TextBox2)
End Sub

Private Sub CommandButton2_Click()
Sheets("VERİ").Range("C4").Value = TextBox1
Sheets("VERİ").Range("C6").Value = TextBox3
Sheets("VERİ").Range("E4").Value = TextBox4
Sheets("VERİ").Range("C5").Value = TextBox5
Sheets("VERİ").Range("E5").Value = TextBox6

Unload UserForm1
End Sub

Private Sub Label3_Click()

End Sub

Private Sub ListBox1_Click()
If ListBox1.ColumnCount = 0 Then Exit Sub
TextBox1.Text = ListBox1.Column(0)
TextBox3.Text = ListBox1.Column(1)
TextBox4.Text = ListBox1.Column(2)
TextBox5.Text = ListBox1.Column(3)
TextBox6.Text = ListBox1.Column(4)
End Sub

Private Sub TextBox2_Change()
TextBox2 = Evaluate("=upper(""" & TextBox2 & """)")
End Sub

Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 5
[color=red]ListBox1.ColumnWidths = "80;150;80;80;60"[/color]
OptionButton1.Value = True
TextBox2.SetFocus
End Sub
Private Sub bul_59(ByVal txt As Control)
Dim sut As String, k As Range, adr As String, myarr(), a As Long
Dim sat As Long, deg
ListBox1.Clear
If txt.Text = "" Then Exit Sub
If txt.Name = "TextBox2" Then
    sut = "B"
    deg = txt.Text
   End If
sat = Sheets("Data").Cells(65536, sut).End(xlUp).Row
ReDim myarr(1 To 5, 1 To 65536)
Set k = Sheets("Data").Range(sut & "2:" & sut & sat). _
Find([color=red]deg & "*"[/color], , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        a = a + 1
        myarr(1, a) = Sheets("Data").Cells(k.Row, "B").Value
        myarr(2, a) = Sheets("Data").Cells(k.Row, "C").Value
        myarr(3, a) = Sheets("Data").Cells(k.Row, "D").Value
        myarr(4, a) = Sheets("Data").Cells(k.Row, "E").Value
        myarr(5, a) = Sheets("Data").Cells(k.Row, "F").Value
        Set k = Sheets("Data").Range(sut & "2:" & sut & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
    ReDim Preserve myarr(1 To 5, 1 To a)
    ListBox1.Column = myarr
End If
End Sub
Genişletmek için tıkla ...


Hocam Valla nedesem az olur süpersin eline emeğine sağlık çok teşekkür ederim Hakkını helal et
 
hamitcan' Alıntı:
Helal olsun, çok bir şey yapmadım.
Genişletmek için tıkla ...

hocam birde buna sil komutu ekleyebilirmiyiz yani listboxta seçilen isim data sayfasından silinsin ama listedeki sıra numarası bozulmasın örneğin ahmet ismi 3. sırada ise silinince 3. yerine bir alt sıradaki isim gelsin bu şekilde düzenleme mümkünmü acaba
 
Sil butonu ekleyin ve şu kodları yapıştırıp deneyin;

Kod: 
Private Sub CommandButton3_Click()
    Dim Rky As Range
    Set Rky = Sayfa2.Columns(2).Find(TextBox1.Text, , , 1)
    If Not Rky Is Nothing Then
        Sayfa2.Select
        Rows(Rky.Row).Delete
        Range("A2").Value = 1
        Range("A2").AutoFill Range("A2", Range("A2").End(4)), Type:=2
        Sayfa1.Select
    End If
    Set Rky = Nothing
End Sub
 
. . .

Alternatif olsun.

Kod: 
Private Sub CommandButton3_Click()
[COLOR="DarkGreen"]' YENİ SİL BUTONU[/COLOR]

Dim SD As Worksheet
Set SD = Sheets("Data")

Set ara = SD.Range("B:B").Find(TextBox1.Text, , xlValues, xlWhole)
If Not ara Is Nothing Then
Adres = ara.Address

Do
If SD.Cells(ara.Row, "B") = TextBox1.Text And _
SD.Cells(ara.Row, "C") = TextBox3.Text And _
SD.Cells(ara.Row, "D") = TextBox4.Text And _
SD.Cells(ara.Row, "E") = TextBox5.Text And _
SD.Cells(ara.Row, "F") = TextBox6.Text Then

Sonsat = SD.[A65536].End(3).Row
SD.Range("A" & ara.Row & ":A" & Sonsat).Copy SD.Range("A" & ara.Row + 1)
SD.Cells(SD.[A65536].End(3).Row, "A") = ""

SD.Rows(ara.Row).Delete
Exit Do
End If

Set ara = SD.Range("B:B").FindNext(ara)
Loop While Not ara Is Nothing And ara.Address <> Adres

End If

CommandButton1_Click
End Sub

. . .
 

Ekli dosyalar

Excel de macro ve user form ödevi hk.

Arkadaşlar merhaba,

Benim de nacizane bir ödevim var. Yardımcı olacak arkadaşlara teşekkür ederim.
 
Yeni konu açarak yapmak istediğinizi belirtebilirsiniz...
 
Hocam Çok özür Dilerim Ya kullandıkça yeni durumlar ortaya çıkıyor son olarak birde düzeltme butonu koyabilirimiyz biliyorum biraz fazla oldum ama gerçekten önemli şimdiden teşekkürler
 
 
Excel de macro ve user form ödevi hk.

Arkadaşlar merhaba,

Benim de nacizane bir ödevim var. Yardımcı olacak arkadaşlara teşekkür ederim.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst