benzersizleri süzerek aktarmam gerek

[gusepir]

selam, ekteki dosyada da belirttiğim gibi, birkaç sütundaki verileri; boş hücreleri yok sayarak ve yinelenenleri kaldırıp diğer sayfaya aktararak tek sütunda alt alta sıralamam gerek... (yinelenenleri kaldırma işlemini çok sütunlu yapıp tek sütuna sıralamak) yardım edebilirseniz, teşekkürler şimdiden

 

[Ömer]

Merhaba,

Olması gereken tabloyu diğer sayfada manuel yazarak dosyanızı tekrar eklermisiniz.

 

[gusepir]

Merhaba,

Olması gereken tabloyu diğer sayfada manuel yazarak dosyanızı tekrar eklermisiniz.

hemen yazdım 2. sayfaya manuel olarak... yükledim...

 

[Ömer]

hemen yazdım 2. sayfaya manuel olarak... yükledim...

Bu şekilde deneyin.

Sub Benzersiz()
 
    Dim s, a1, deg, alan As Range, i As Long, S1 As Worksheet, son As Long
 
    Set S1 = Sheets("Sayfa1")
    son = S1.Range("A:E").Find("*", , , , xlByRows, xlPrevious).Row
 
    Application.ScreenUpdating = False
    Sheets("Sayfa2").Select
    Range("A:A").ClearContents
 
    With CreateObject("Scripting.Dictionary")
        For Each alan In S1.Range("A1:E" & son)
            deg = alan
            If deg <> "" Then
                If Not .exists(deg) Then
                    s = Array(1, deg)
                    .Add deg, s
                End If
            End If
        Next alan
        a1 = .keys
        For i = 0 To .Count - 1
            Cells(i + 1, "A") = a1(i)
        Next i
    End With
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[gusepir]

tamam gibi görünüyor, sadece ortada bir boş satır bırakmış listelerken, veri girişinde bir sorun çıkarıp çıkarmadığını deniycem... çok teşekkür ederim, saygılar

(bu arada, nereden girdiysem siteye, sabahtan beri okuyorum forumdakileri, kahvaltı bile yapmadım, o kadar yani )

 

[Ömer]

Haklısınız bağımlılık yapıyor

Ben denediğimde satır bırakmamıştı. Güçük bir değişiklik yapmıştım geç kalmışta olabilirim. Üsteki kodları tekrar kopyalayıp denermisiniz yine olmazsa tek satır kalan dosyayı eklermisiniz.

 

[Necdet]

Merhaba,

"Scripting.Dictionary" bilmeyenler için alternatif çözüm.
Klasik yöntem, ara yoksa aktar mantığı.

Not : Scripting.Dictionary her zaman daha hızlıdır.

Sub Benzersiz()
 
    Dim i   As Long, _
        Hcr As Range, _
        s1  As Worksheet, _
        s2  As Worksheet, _
        c   As Range
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    s2.Range("A:A").ClearContents
    s2.Range("A1") = "Benzersizler"
    i = 1
    
    s1.Select
    
    For Each Hcr In Range("A1").CurrentRegion
        Hcr = Application.WorksheetFunction.Trim(Hcr)
        If Not Hcr = "" Then
            Set c = s2.Range("A:A").Find(Hcr.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If c Is Nothing Then
                i = i + 1
                s2.Cells(i, "A") = Hcr
            End If
        End If
    Next Hcr
    
End Sub

 

[gusepir]

her ikinizin de verdiği kodu kopyasını oluşturduğum dosyalara girdim...
ömer bey'in kodunda büyük küçük harf duyarlı olarak mükerrerlikler oluşmuş, necdet bey'in kodunda da bir eksik isim vardı(giriş yaptığım hücre biçimlendirmesi hatalıymış)... ve her ikisinde de tek satır boşluk halen duruyor, bulurum ama nedenini, muhtemelen yine benim giriş hatamdandır...
sonuçta verilerin girişini de kontrol altında tutmam gerek anladığım kadarıyla, büyük küçük harf veya hücre biçimlendirmesi açısından... yüzlerce veriyi, başka birimlerden alıp copy paste ile birleştirecektim... bu durumda, ilgili birimlere formatı ve veri girişi kontrollu bir şablon göndererek çözerim bu işi...

bu haliyle işimi göreceğini düşünüyorum..

günlerdir, formüllerle kendi çapımda boğuşup çıkamadığım işin içinden çıkardınız beni... çok teşekkürler ederim.. saygılar

 

[Necdet]

Merhaba,

Boş satır var dediğiniz büyük olasılıkla o boş değildir.

 

[gusepir]

tüm sütunlardaki hücreleri tekrar biçimlendirip tekleştirerek kodu çalıştırdım... ama yine ortalarda bir boş satır var görebildiğim kadarıyla, sanırım veri girişlerini yenileyince hallolur

 

[Ömer]

tüm sütunlardaki hücreleri tekrar biçimlendirip tekleştirerek kodu çalıştırdım... ama yine ortalarda bir boş satır var görebildiğim kadarıyla, sanırım veri girişlerini yenileyince hallolur

Bu şekilde sonuclanan dosyanızı eklermisiniz.

Kodlarda sütunu da parametrik yaptım.

Sub Benzersiz()
 
    Dim s, a1, deg, alan As Range, i As Long, S1 As Worksheet
    Dim sat As Long, sut As Integer
 
    Set S1 = Sheets("Sayfa1")
    sat = S1.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    sut = S1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
 
    Application.ScreenUpdating = False
    Sheets("Sayfa2").Select
    Range("A:A").ClearContents
 
    With CreateObject("Scripting.Dictionary")
        For Each alan In S1.Range(S1.Cells(1, 1), S1.Cells(sat, sut))
            deg = [COLOR=red]Trim([/COLOR]alan[COLOR=red])[/COLOR]
            If deg <> "" Then
                If Not .exists(deg) Then
                    s = Array(1, deg)
                    .Add deg, s
                End If
            End If
        Next alan
        a1 = .keys
        For i = 0 To .Count - 1
            Cells(i + 1, "A") = a1(i)
        Next i
    End With
    Application.ScreenUpdating = True
 
End Sub

.

 

[gusepir]

buyrun hocam ekledim dosyayı...

 

[Necdet]

Merhaba,

7 nolu mesajımdaki kodları ve dosyayı yeniledim.

D14 hücresi boş değil içinde tek bir karakter boşluk var. O yüzden boş satır oluşuyor.

7 nolu mesajdaki kodları alırsanız bu hata ortadan kalkar.

 

[Ömer]

Boş hücrenin sebebi:

Sayfa1 D14 hücresi boş gözüksede boş değil, çünkü içerisinde bir boşluk karakteri var. D14 hücresini silip kodu çalıştırırsanız farkı görebilirsiniz.

Farklı hücrelerde de aynı sorun olma ihtimaline karşılık #11 numaralı mesajı değiştirdim. Yeni kodlara göre tekrar denermisiniz.

 

[gusepir]

tamamdır hocam, tahmin ettiğim gibi, giriş hatamdan kaynaklıymış halloldu... çok teşekkür ederim...