mükerrer kayıt

[memduh]

Aşağıda Sayın Leventm Beyin verdiği kodlarda textbox a girdiğim isme göre listbox a veri alıyor. alınan isimlerden iki ve daha fazlasını teke olrak listboxa göztermesini istiyorum. Mükerrer kayıtla ilgili arşivi inceledim fakat uayarlama bu kod mantığına göre yapamadım yardımcı olursanız sevinirim.Saygılar.
Private Sub TextBox1_Change()
Dim MyRng As Range
ListBox1.Clear

If TextBox1 <> Empty Then
For Each MyRng In Sheets("sayfa1").Range("c7:c" & _
Sheets("sayfa1").Range("c65536").End(xlUp).Row)
If LCase(MyRng) Like LCase(TextBox1 & "*") Then ListBox1.AddItem MyRng
Next
End If
End Sub

 

[Levent Menteşoğlu]

Dosyanızı eklerseniz onun üzerinden gidelim.

 

[memduh]

Dosya Ektedir.



Excel-2003 Türkçe

 

[excelman]

Private Sub ListBox1_Click() 
Dim i 
With ListBox2 
.Clear 
For i = 1 To Range("a65536").End(xlUp).Row 
If UCase(Cells(i, "a")) Like UCase(TextBox1) Then 
.AddItem 
.List(.ListCount - 1, 0) = Cells(i, "B") 
End If 
Next 
End With 
End Sub

 

[excelman]

Sayın Memduh

Dosyanızda değişiklikler yaptım işinize yararsa kullanabilirsiniz.

 

[Levent Menteşoğlu]

Private Sub ListBox1_Click()
Dim i
With ListBox2
.Clear
For i = 1 To Range("a65536").End(xlUp).Row
If UCase(Cells(i, "a")) Like UCase(TextBox1) Then
.AddItem
.List(.ListCount - 1, 0) = Cells(i, "B")
End If
Next
End With
End Sub

Bahsi geçen kodlar bana ait değildir. Bu düzeltmeyide yapalım.

 

[aligunes]

mükerrer kayıtla ilgili bir sorum da benim var sayfa 1 de a stununda listem var bu listede mükerrer olan sicil numaralarının mükerrer olanlarını sayfa 2 ye atabilir mi?
saygılar.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

[vb:1:69e75daf49]Sub aktar()
For a = 1 To Cells(65536, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, 1)) > 1 Then
c = c + 1
Sheets("sayfa2").Cells(c, 1) = Cells(a, 1).Value
End If
Next
End Sub[/vb:1:69e75daf49]

 

[aligunes]

leventm peki sicilin karşılıkları olan b c d e sutunundaki bilgileri karşısına nasıl yazabiliriz.

 

[Levent Menteşoğlu]

Aşağıdaki gibi deneyin.

[vb:1:70bfda0318]Sub aktar()
For a = 1 To Cells(65536, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, 1)) > 1 Then
c = c + 1
Sheets("sayfa2").Cells(c, 1) = Cells(a, 1).Value
Sheets("sayfa2").Cells(c, 2) = Cells(a, 2).Value
Sheets("sayfa2").Cells(c, 3) = Cells(a, 3).Value
Sheets("sayfa2").Cells(c, 4) = Cells(a, 4).Value
End If
Next
End Sub [/vb:1:70bfda0318]

Birde aşağıdaki linki inceleyin.

http://www.excel.web.tr/viewtopic.php?t=3546&highlight=m%FCkerrer