Birden Fazla ise sadece birini yazsın

[imdatsaral]

Selam Arkadaşlar,
ekte gönderdiğim dosyada H Sütunundaki hücreye çift tıkladığmda UserForm açılıyor
açılan listede kumaş cinsleri var. Benim istediğim aynı cins kumaşlardan
sadece birini yazması örneğin 20/1 100% COTTON SÜP. listede 5 adet
var benim için biri yeterli. Birde hücre doysa userform açılmasın.
Yardımcı olursanız sevinirim

 

[Necdet]

Merhaba,

H sütunundaki kodların sıralı olduğunu varsayarak,
Sayfadaki kodları aşağıdaki gibi dener misiniz?

Yok sıralamak istemiyorum derseniz kodlarda değişiklik yapmak gerek.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [H2:H4000]) Is Nothing Then Exit Sub
For i = 2 To [H65536].End(3).Row
    If Cells(i, "H") <> Cells(i - 1, "H") Then
        UserForm6.ListBox1.AddItem Cells(i, "H")
    End If
Next i
UserForm6.Show
Cancel = True
End Sub

 

[imdatsaral]

Necdet Yeşertener Listeyi sıralama yapılabirse daha iyi olur gerçek dosyada liste daha uzun ve çeşit çok istenileni bulmada kolaylık olur. Ayrıca bir isteğim daha olacak hücre boşsa userform açılmasın
teşekkür ederim

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [H2:H4000]) Is Nothing Then Exit Sub
Dim i, Son As Long
Son = [H65536].End(3).Row
If Son = 1 Then Exit Sub
Range("H2:H" & Son).Sort Key1:=[H2], Order1:=xlAscending
For i = 2 To Son
    If Cells(i, "H") <> Cells(i - 1, "H") Then
        UserForm6.ListBox1.AddItem Cells(i, "H")
    End If
Next i
UserForm6.Show
Cancel = True
End Sub

 

[imdatsaral]

Hocam sıralama sadece ListBoxta olmalı. Listem karışmamalı çünkü numara takibi yapılıyor. Kumaş stok noları bu sayfa üzerinden yapılıyor.

 

[Necdet]

Merhaba,

Bubble Sort kullandım.

http://support.microsoft.com/kb/133135

sipariş sayfasındaki kodlar

Option Base 1
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [H2:H4000]) Is Nothing Then Exit Sub
Dim i, Son As Long
Dim Adet As Integer
Dim Dizi() As Variant
Son = [H65536].End(3).Row
ReDim Preserve Dizi(Son)
Adet = 0
If Son = 1 Then Exit Sub
UserForm6.ListBox1.Clear

For i = 2 To Son
    If Application.WorksheetFunction.CountIf(Range("H2:H" & i), Cells(i, "H")) = 1 Then
       Adet = Adet + 1
       Dizi(Adet) = Cells(i, "H")
    End If
Next i
BubbleSort Dizi
For i = 1 To UBound(Dizi)
    If Dizi(i) <> "" Then UserForm6.ListBox1.AddItem Dizi(i)
Next i
UserForm6.Show
Cancel = True
End Sub

Modüldeki kodlar

 Option Base 1
'http://support.microsoft.com/kb/133135
Function BubbleSort(TempArray As Variant)
    Dim Temp As Variant
    Dim i As Integer
    Dim NoExchanges As Integer
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
        ' Loop through each element in the array.
        For i = 1 To UBound(TempArray) - 1
            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If TempArray(i) > TempArray(i + 1) Then
                NoExchanges = False
                Temp = TempArray(i)
                TempArray(i) = TempArray(i + 1)
                TempArray(i + 1) = Temp
            End If
        Next i
    Loop While Not (NoExchanges)
End Function

 

[imdatsaral]

Hocam çok teşekkür ederim. Emeğinize bilginize sağlık.
istediğim gibi oldu.