Makro ile liste içerisindeki benzersiz değerleri alma

[bhdr]

Herkese Merhaba;

Makro ile yapmak istediğim bir durum var ve sizlerden yardım bekliyorum. Durumun özeti aşağıdaki gibidir.

1- makro çalıştığında öğrenciler sayfasındaki birbiri ile aynı olan değerlerden sadece 1 tanesini şube sayfasına yazacak. (dosya içerisinde örnek vardır)

2- makro çalıştığında öğrenciler sayfasındaki her dersin verildiği benzersiz okullar ve bu okulların kodları ve isimlerini getirmek istiyorum. (dosya içerisinde örnek vardır.)

Kısaca şartlara bağlı benzersiz değerleri kriterlere göre diğer sayfalara aktarmak istiyorum.

Teşekkürler.

 

[bhdr]

Dosyayı Ekledim.

 

[çıtır]

Deneyiniz

Sub Benzersiz()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim s3 As Worksheet
Set s1 = Sheets("ÖĞRENCİLER"): Set s2 = Sheets("ŞUBE"): Set s3 = Sheets("OKUL")
son = s1.Cells(65355, "A").End(3).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 s2.Range("A1:E" & Rows.Count).Cells.ClearContents
    s1.Range("B1:F" & son).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A1"), Unique:=True
    
    s3.Range("A1:F" & Rows.Count).Cells.ClearContents
    s1.Range("B1:E" & son).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s3.Range("A1"), Unique:=True
   
    s1.Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

 

[bhdr]

Deneyiniz

Sub Benzersiz()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim s3 As Worksheet
Set s1 = Sheets("ÖĞRENCİLER"): Set s2 = Sheets("ŞUBE"): Set s3 = Sheets("OKUL")
son = s1.Cells(65355, "A").End(3).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
s2.Range("A1:E" & Rows.Count).Cells.ClearContents
    s1.Range("B1:F" & son).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A1"), Unique:=True
   
    s3.Range("A1:F" & Rows.Count).Cells.ClearContents
    s1.Range("B1:E" & son).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s3.Range("A1"), Unique:=True
  
    s1.Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

Çok teşekkür ederim.

 

[çıtır]

Çok teşekkür ederim.

Rica ederim.Dönüş yaptığınız için teşekkür ederim.