Belirtilen sayfalardaki benzersizleri getir ve sırala

[tahsinanarat]

Ekte gönderdiğim örnek dosyamın Girdi ve Cikti sayfalarının B sutunlarındaki Kodları Envanter1 sayfa adlı sayfanın A sutununa benzersiz olarak küçükten büyüğe doğru sıralamasını yapmak istiyorum.

Yardımcı olacak arkadaşlarıma, hocalarıma şimdiden teşekkürler.

Kolay Gelsin Tahsin.

 

[tahsinanarat]

Biraz uğraştıktan sonra aşağıdaki kodlar ile hallettim.

Sub Benzersiz_kod()

    Dim d As Object, j As Integer, i As Long, s, deg

    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Envanter1").Select
    Range("A2:A65536").ClearContents

    For j = 1 To Worksheets.Count
        With Sheets(j)
            If .Name = "Girdi" Or .Name = "Cikti" Then
                For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
                    deg = .Cells(i, "B")
                    If Not d.exists(deg) Then
                        d.Add deg, Nothing
                    End If
                Next i
            End If
        End With
    Next j

    Range("A5").Resize(d.Count, 1) = _
        Application.Transpose(Array(d.keys))

    Application.ScreenUpdating = True

End Sub

 

[dEdE]

Dener misiniz?

Sub Test()
Set s1 = Sheets("Girdi")
Set s2 = Sheets("Cikti")
Set s3 = Sheets("Envanter1")
    ss1 = s1.Cells(Rows.Count, "B").End(3).Row
    ss2 = s2.Cells(Rows.Count, "B").End(3).Row
    ss3 = s3.Cells(Rows.Count, "A").End(3).Row
   
    s3.Range("A5:A" & ss3).ClearContents
    s1.Range("B2:B" & ss1).Copy s3.Range("A5")
    ss3 = s3.Cells(Rows.Count, "A").End(3).Row
    s2.Range("B2:B" & ss2).Copy s3.Range("A" & ss3 + 1)
    ss3 = s3.Cells(Rows.Count, "A").End(3).Row

    ReDim Dizi(ss3)
    myArr = s3.Range("A5:A" & ss3)
    Set myList = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
myList.Sort
    s3.Range("A5:A" & ss3).ClearContents

For k = 0 To myList.Count - 1
Cells(k + 5, 1) = myList(k)
Next
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub UNIQUE_SORT()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Girdi")
    Set S2 = Sheets("Cikti")
    Set S3 = Sheets("Envanter1")
    
    S3.Range("A5:A" & S3.Rows.Count).ClearContents
    
    S1.Range("B2:B" & S1.Cells(S1.Rows.Count, 2).End(3).Row).Copy
    S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).PasteSpecial xlValues
    S2.Range("B2:B" & S2.Cells(S2.Rows.Count, 2).End(3).Row).Copy
    S3.Cells(S3.Rows.Count, 1).End(3)(2, 1).PasteSpecial xlValues
    S3.Range("A4").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    S3.Range("A5:A" & S3.Rows.Count).Sort S3.Range("A5"), xlAscending
    S3.Range("A4").CurrentRegion.Borders.LineStyle = 1
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing

    Application.ScreenUpdating = True
End Sub

 

[Haluk]

Alternatif;

Sub Test()
    Set objConn = CreateObject("ADODB.Connection")
    
    Set RS = CreateObject("ADODB.Recordset")
    
    dbExcel = ThisWorkbook.FullName
    
    objConn.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & dbExcel & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
    
    strSQL = "Select [KOD] From [Girdi$] Union Select [KOD] From [Cikti$] Order By [Kod] Asc"
    
    RS.Open strSQL, objConn
    
    Sheets("Envanter1").Range("A5").CopyFromRecordset RS
    
    Set RS = Nothing
    Set objConn = Nothing
End Sub

.

 

[dEdE]

strSQL = "Select [KOD] From [Girdi$] Union Select [KOD] From [Cikti$] Order By [Kod] Asc"
RS.Open strSQL, objConn
Sheets("Envanter1").Range("A5").CopyFromRecordset RS

Sayın Haluk Hocam,
ADO konusunu anlamak adına yukarıdaki üç satırı açıklayabilir misiniz?
Teşekkürler.

 

[Haluk]

@dEdE ;

Girdi ve Çıktı sayfalarında "KOD" isimli sütunlardaki verileri alt alta birleştirerek artan sıralamayla oluşturulan tabloyu bir "Recordset" nesnesine aktarıp, bunu "Envanter1" sayfasında A5 hücresinden itibaren aşağıya doğru yerleştiriyor.

.

 

[Korhan Ayhan]

Üstad Union ile birleştirme yapınca sanırım kendi BENZERSİZ hale getiriyor. Genelde Distinct kullanımını biliyordum. Bu da ek bir bilgi oldu. Teşekkürler.

 

[tahsinanarat]

Sn. @dEdE , Sn. @Korhan Ayhan ve Sn. @Haluk Hocam, hepinizin ellerine fikrine sağlık, hepsini ayrı ayrı test ettim hepsi de mükemmel çalışıyor.
Sn. Haluk hocam sizin A5 yerine A6 hücresine yapıştırıp, A5 satırında yok hatası veriyor, ancak sonuç doğru, çözüm yoksa A5 satırını kod ile sildirmeyi düşünüyorum.
Hepinize ayrı ayrı teşekkür ediyorum. Hayırlı geceler diliyorum.

 

[tahsinanarat]

Sn. @Haluk hocam verdiğim örnek dosyamda denedim onda herhangi bir hata satırı vermedi, düzgün çalıştı, Bilginize.
Belki benim orjinal datamda bir hata olabilir onlara bakacağım.
Orjinal dosyamın cikti sayfasında aralarda Kodu yazılmamış bir boş satır varmış, onu sildiğimde düzeldi Hocam.

Saygılar.

 

[Haluk]

Üstad Union ile birleştirme yapınca sanırım kendi BENZERSİZ hale getiriyor. Genelde Distinct kullanımını biliyordum. Bu da ek bir bilgi oldu. Teşekkürler.

Korhan Bey, "Benzersiz" hale getirmemek için "Union All" kullanabilirsiniz.

.