[Yardım]  Userform ile sayfada benzersiz sırala

Metin Kutucuğu. Bir programcının olmazsa olmazlarındandır.

Userform ile sayfada benzersiz sırala

İleti#1)  Süleyman SAVAŞ » 07 Kas 2018 23:23

Merhaba arkadaşlar.
Kod: Tümünü seç
Private Sub CommandButton2_Click() 
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row
sorgu = "SELECT [F1] From [Sayfa1$A2:A" & satir & "] Group By [F1]"
rs.Open sorgu, con, 1, 1
Range("D2").CopyFromRecordset rs
rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = False
For i = 1 To Cells(Rows.Count, "D").End(3).Row - 1
             
Range("C" & i + 1) = i
NextEnd Sub

Bu makro ile sayfada benzersiz sıralama yapıyorum.
İstiyorum ki; ekli listede bulunan form ile bu işlemi yapabilelim. Sonra formu eklenti olarak kaydedip bütün excel sayfalarında kullanabileyim.
Ayrıntılı açıklama dosyada mevcut.
Zamanı müsait olan arkadaşların ilgisini rica ediyorum.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
Süleyman SAVAŞ
Siteye Alışmış
 
Adı Soyadı:Süleyman Savaş
Kayıt: 05 May 2009 14:05
Konum: Bursa
Meslek: 657
Yaş: 46
İleti: 382
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Bursa/Gemlik

Cevap: Userform ile sayfada benzersiz sırala

İleti#2)  feraz » 08 Kas 2018 01:54

Biraz daha ayar gerekebilir.

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String

Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row


sorgu = "SELECT [F1] From [Sayfa1$" & hedefSutun & 2 & ":" & hedefSutun & satir & "]"" Group By [F1]"

sorgu = Split(sorgu, """")(0) & Split(sorgu, """")(1)

rs.Open sorgu, con, 1, 1
Cells(2, yazlaSaksutun).CopyFromRecordset rs

For i = 2 To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - 1
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True


End Sub
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Userform ile sayfada benzersiz sırala

İleti#3)  feraz » 08 Kas 2018 03:46

Alttaki kodu deneyin.
] bu kısmı bir türlü ayarlayamamıştım ve split kullanmıştım.
Şimdi çözdüm.

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String

Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row

sorgu = "SELECT [F1] From [Sayfa1$" & hedefSutun & 2 & ":" & hedefSutun & satir & "] Group By [F1]"

rs.Open sorgu, con, 1, 1
Cells(2, yazlaSaksutun).CopyFromRecordset rs

For i = 2 To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - 1
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True

End Sub
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Cevap: Userform ile sayfada benzersiz sırala

İleti#4)  Süleyman SAVAŞ » 08 Kas 2018 09:38

feraz yazdı:Alttaki kodu deneyin.
] bu kısmı bir türlü ayarlayamamıştım ve split kullanmıştım.
Şimdi çözdüm.

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String

Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row

sorgu = "SELECT [F1] From [Sayfa1$" & hedefSutun & 2 & ":" & hedefSutun & satir & "] Group By [F1]"

rs.Open sorgu, con, 1, 1
Cells(2, yazlaSaksutun).CopyFromRecordset rs

For i = 2 To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - 1
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True

End Sub

Teşekkürler feraz üstat.
Form eklenti olarak çalışacağı için çalışılan sayfa ismi Sayfa1 olmayabilir. Dolayısıyla Sorgu satırındaki
Kod: Tümünü seç
sorgu = "SELECT [F1] From [Sayfa1$" & hedefSutun & 2 & ":" & hedefSutun & satir & "] Group By [F1]"
Sayfa1'i tanımlaması çalışılan sayfa adını alırsa işlem tamamlanmış olacak.
Kullanıcı avatarı
Süleyman SAVAŞ
Siteye Alışmış
 
Adı Soyadı:Süleyman Savaş
Kayıt: 05 May 2009 14:05
Konum: Bursa
Meslek: 657
Yaş: 46
İleti: 382
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Bursa/Gemlik

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Userform ile sayfada benzersiz sırala

İleti#5)  feraz » 08 Kas 2018 12:41

İki adet textbox vardı ona göre yapmıştım.
Sayfayı hallederken hangi satırdan başlayacağınıda halledeyim :)
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Userform ile sayfada benzersiz sırala

İleti#6)  feraz » 08 Kas 2018 13:15

Kaydedilecek satır numarayıda ekledim.
Sayfa adınıda işlem yapılan sayfadan aldım.
İsterseniz bir combo ekleyip comboya sayfa adlarınıda çekip yapabilirsiniz.


Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim syfa
Dim satrNosec As Integer


Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value
syfa = ActiveSheet.Name & "$"

On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row

sorgu = "SELECT [F1] From [" & syfa & hedefSutun & satrNosec & ":" & hedefSutun & satir & "] Group By [F1]"

rs.Open sorgu, con, 1, 1
Cells(satrNosec, yazlaSaksutun).CopyFromRecordset rs

For i = satrNosec To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - 1
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True


End Sub
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Userform ile sayfada benzersiz sırala

İleti#7)  feraz » 08 Kas 2018 13:19

Sıralamada mantık hatası olmuş.

Cells(i, Columns(yazlaSaksutun).Column - 1) = i - (satrNosec - 1) böyle yaptım.

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim syfa
Dim satrNosec As Integer


Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value
syfa = ActiveSheet.Name & "$"

On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row

sorgu = "SELECT [F1] From [" & syfa & hedefSutun & satrNosec & ":" & hedefSutun & satir & "] Group By [F1]"

rs.Open sorgu, con, 1, 1
Cells(satrNosec, yazlaSaksutun).CopyFromRecordset rs

For i = satrNosec To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - (satrNosec - 1)
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True


End Sub
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Cevap: Userform ile sayfada benzersiz sırala

İleti#8)  Süleyman SAVAŞ » 08 Kas 2018 14:15

feraz yazdı:Sıralamada mantık hatası olmuş.

Cells(i, Columns(yazlaSaksutun).Column - 1) = i - (satrNosec - 1) böyle yaptım.

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim syfa
Dim satrNosec As Integer


Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value
syfa = ActiveSheet.Name & "$"

On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Range("A2").End(4).Row

sorgu = "SELECT [F1] From [" & syfa & hedefSutun & satrNosec & ":" & hedefSutun & satir & "] Group By [F1]"

rs.Open sorgu, con, 1, 1
Cells(satrNosec, yazlaSaksutun).CopyFromRecordset rs

For i = satrNosec To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - (satrNosec - 1)
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True


End Sub

Eyvallah üstat eline emeğine sağlık.
Kod sayfadaki userformda sorunsuz çalışıyor. Sayfa ismi de değişse sorun çıkmıyor.
Sorun; kod eklenti olarak kullandığım formda çalışmadı.
Mevcut dosya ile beraber eklenti formunu da ekledim. Rica etsem eklenti üzerinde neden çalışmadı, buna bir bakmanız.

Konuyu takip edenler açısından eklentinin nereye atılacağı ve nasıl çalışacağı yönünde basit tarif yapayım.
Öncelikle gizli dosyalar görünmüyorsa denetim masasından görünür yapıp eklentiyi Kullanıcı Adı>AppData>Roaming>Microsoft>Excel>Xlstart yoluna kopyalıyoruz.

Resimlerle izah etmeye çalıştım.
Resim
Resim
Resim
Resim
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
Süleyman SAVAŞ
Siteye Alışmış
 
Adı Soyadı:Süleyman Savaş
Kayıt: 05 May 2009 14:05
Konum: Bursa
Meslek: 657
Yaş: 46
İleti: 382
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Bursa/Gemlik

Cevap: Userform ile sayfada benzersiz sırala

İleti#9)  feraz » 08 Kas 2018 15:05

Rica ederim.

Eklenti olayına akşam bakabilirim.
Ve işin açığı fazla bir bilgim yok eklenti olayında.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Userform ile sayfada benzersiz sırala

İleti#10)  feraz » 09 Kas 2018 03:45

Alttaki gibi kodu derleyince resimdeki gibi hata vaeriyor sebebini anlayamadım normalde seçim aralığı doğru.
Sorgunun doğru olduğu ilk resimde belli.

Birde sorgu = "SELECT [F1] From [" & syfa & hedefSutun & satrNosec & ":" & hedefSutun & satir & "] Group By [F1]"
burdaki satrNosec yerine 2 rakamı gelmeli yada extra nir inputbox ile belirlenmeli.


Kod: Tümünü seç
Private Sub CommandButton7_Click()


Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim syfa
Dim satrNosec As Integer
Dim con As Object
Dim rs As Object
Dim i As Integer
Dim satir As Long, sorgu As String

Application.ScreenUpdating = False

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value
syfa = ActiveSheet.Name & "$"

'On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""excel 12.0;HDR=No"""
satir = Cells(Rows.Count, hedefSutun).End(3).Row

sorgu = "SELECT [F1] From [" & syfa & hedefSutun & 2 & ":" & hedefSutun & satir & "] Group By [F1]"

rs.Open sorgu, con, 1, 1
Cells(satrNosec, yazlaSaksutun).CopyFromRecordset rs

For i = satrNosec To Cells(Rows.Count, yazlaSaksutun).End(3).Row
    Cells(i, Columns(yazlaSaksutun).Column - 1) = i - (satrNosec - 1)
Next

rs.Close
Set con = Nothing: Set rs = Nothing: sorgu = ""
       
Application.ScreenUpdating = True

End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Userform ile sayfada benzersiz sırala

İleti#11)  feraz » 09 Kas 2018 05:02

Birde Dictionary ile deneyin.

Yazılacak Sütun textboxuna sayıların sıralanacağı sütunu seçin.Yani 1,2,3 vs...

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim satrNosec As Integer
Dim aranan
Dim srala  As Integer
Dim arama As Object, i, Say, satir As Long, dizim, veri
Set arama = CreateObject("Scripting.Dictionary")

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value


On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value

arama.comparemode = 1 '0 küçük büyük harfide ekler,1 ise tek yapar.
On Error Resume Next
Application.ScreenUpdating = False
   
With Sheets(ActiveSheet.Name)
   
     srala = .Cells(1, yazlaSaksutun).Column + 1
    .Range(.Cells(satrNosec, yazlaSaksutun).Address, .Range(.Cells(Rows.Count, srala).Address)).ClearContents
    satir = .Cells(Rows.Count, hedefSutun).End(3).Row
   
    veri = Range(hedefSutun & 2 & ":" & hedefSutun & satir).Value
   
    ReDim dizim(1 To satir, 1 To 1)
        For i = 1 To UBound(veri, 1)
            aranan = veri(i, 1)
            If Not arama.exists(aranan) Then
                Say = Say + 1
                arama.Add aranan, Say
                ReDim Preserve dizim(1 To satir, 1 To 1)
                dizim(Say, 1) = aranan
            End If
        Next i
             
   .Cells(satrNosec, yazlaSaksutun).Resize(arama.Count, 1) = Application.Transpose(arama.items)
   .Cells(satrNosec, srala).Resize(arama.Count, 1).Value = dizim
   .Cells(satrNosec, srala).Resize(arama.Count, 1).Sort Key1:=.Cells(satrNosec, srala), Order1:=xlAscending, Header:=xlNo

End With

Application.ScreenUpdating = True

Set arama = Nothing


End Sub
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Cevap: Userform ile sayfada benzersiz sırala

İleti#12)  Süleyman SAVAŞ » 09 Kas 2018 12:14

feraz yazdı:Birde Dictionary ile deneyin.

Yazılacak Sütun textboxuna sayıların sıralanacağı sütunu seçin.Yani 1,2,3 vs...

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim satrNosec As Integer
Dim aranan
Dim srala  As Integer
Dim arama As Object, i, Say, satir As Long, dizim, veri
Set arama = CreateObject("Scripting.Dictionary")

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value


On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value

arama.comparemode = 1 '0 küçük büyük harfide ekler,1 ise tek yapar.
On Error Resume Next
Application.ScreenUpdating = False
   
With Sheets(ActiveSheet.Name)
   
     srala = .Cells(1, yazlaSaksutun).Column + 1
    .Range(.Cells(satrNosec, yazlaSaksutun).Address, .Range(.Cells(Rows.Count, srala).Address)).ClearContents
    satir = .Cells(Rows.Count, hedefSutun).End(3).Row
   
    veri = Range(hedefSutun & 2 & ":" & hedefSutun & satir).Value
   
    ReDim dizim(1 To satir, 1 To 1)
        For i = 1 To UBound(veri, 1)
            aranan = veri(i, 1)
            If Not arama.exists(aranan) Then
                Say = Say + 1
                arama.Add aranan, Say
                ReDim Preserve dizim(1 To satir, 1 To 1)
                dizim(Say, 1) = aranan
            End If
        Next i
             
   .Cells(satrNosec, yazlaSaksutun).Resize(arama.Count, 1) = Application.Transpose(arama.items)
   .Cells(satrNosec, srala).Resize(arama.Count, 1).Value = dizim
   .Cells(satrNosec, srala).Resize(arama.Count, 1).Sort Key1:=.Cells(satrNosec, srala), Order1:=xlAscending, Header:=xlNo

End With

Application.ScreenUpdating = True

Set arama = Nothing


End Sub


şkşk Teşekkürler feraz üstadım. Sorunsuz çalışıyor.
Kullanıcı avatarı
Süleyman SAVAŞ
Siteye Alışmış
 
Adı Soyadı:Süleyman Savaş
Kayıt: 05 May 2009 14:05
Konum: Bursa
Meslek: 657
Yaş: 46
İleti: 382
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Bursa/Gemlik

Cevap: Userform ile sayfada benzersiz sırala

İleti#13)  feraz » 09 Kas 2018 14:08

Rica ederim.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: Userform ile sayfada benzersiz sırala

İleti#14)  feraz » 10 Kas 2018 01:40

Kodu alttaki gibi değiştiriseniz gereksiz bir döngüden kurtulmuş oluruz.
Dikkat etmemişim.

Kod: Tümünü seç
Private Sub CommandButton7_Click()

Dim hedefSutun As String
Dim yazlaSaksutun As String
Dim satrNosec As Integer
Dim srala  As Integer
Dim arama As Object, i, Say, satir As Long, dizim, veri
Set arama = CreateObject("Scripting.Dictionary")

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value


On Error Resume Next
satrNosec = InputBox("Satir no sec..")

If satrNosec = 0 Then
    MsgBox "islem iptal..", vbCritical
    Exit Sub
End If

hedefSutun = Me.TextBox12.Value
yazlaSaksutun = Me.TextBox13.Value

arama.comparemode = 1 '0 küçük büyük harfide ekler,1 ise tek yapar.
On Error Resume Next
Application.ScreenUpdating = False
   
With Sheets(ActiveSheet.Name)
   
     srala = .Cells(1, yazlaSaksutun).Column + 1
    .Range(.Cells(satrNosec, yazlaSaksutun).Address, .Range(.Cells(Rows.Count, srala).Address)).ClearContents
    satir = .Cells(Rows.Count, hedefSutun).End(3).Row
   
    veri = Range(hedefSutun & 2 & ":" & hedefSutun & satir).Value
   
    ReDim dizim(1 To satir, 1 To 1)
        For i = 1 To UBound(veri, 1)
            If Not arama.exists(veri(i, 1)) Then
                Say = Say + 1
                arama.Add veri(i, 1), Say
                ReDim Preserve dizim(1 To satir, 1 To 1)
                dizim(Say, 1) = veri(i, 1)
            End If
        Next i
             
   .Cells(satrNosec, yazlaSaksutun).Resize(arama.Count, 1) = Application.Transpose(arama.items)
   .Cells(satrNosec, srala).Resize(arama.Count, 1).Value = dizim
   .Cells(satrNosec, srala).Resize(arama.Count, 1).Sort Key1:=.Cells(satrNosec, srala), Order1:=xlAscending, Header:=xlNo

End With
Application.ScreenUpdating = True
Set arama = Nothing

End Sub
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5456
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray


Forum TextBox

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 1 misafir

Bumerang - Yazarkafe