Listele yapma

[sahika51]

İyi Günler;
Bir tablo var ve burda şartı tutan durumların sayfa 1 e listelemesini istiyorum.
D4, D5 ve D6 verileri sheet1 den alıyor. Girilen değerlere göre aşağıdaki ad soyad kısmına listenin oluşması gerekiyor. Listeye sıra Numarasıda atasın. Şimdiden Teşekkür Ederim.

 

[askm]

Sub askm()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sayfa1")
s2.Select
Dim son As Long
a = 10
s2.Range("A10:E65000").UnMerge
s2.Range("A10:E10").ClearContents
s2.Range("A11:R65000").Clear
son = s1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 6 To son
    If s1.Cells(i, 1) = s2.Cells(4, 4) And s1.Cells(i, 7) = s2.Cells(5, 4) And s1.Cells(i, 8) = s2.Cells(6, 4) Then
        s2.Range("B" & a & ":E" & a).Merge
        s2.Cells(a, 1) = a - 9
        s2.Cells(a, 2) = s1.Cells(i, 5)
        s2.Cells(a, 2).HorizontalAlignment = xlLeft
        If a > 10 Then
            s2.Range("A10:R10").Copy
            s2.Range("A" & a).PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End If
        a = a + 1
    End If
Next i
Range("B10").Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[Orion1]

Alternatif;
Dosyanız ektedir.

Sub aktarogrenci59()
Dim i As Long, sat As Long, sno As Long, sh As Worksheet
Dim sonsat As Long
Sheets("Sayfa1").Select
Range("A10:R" & Rows.Count).ClearContents
Set sh = Sheets("Sheet1")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat = 10
For i = 6 To sonsat
    If sh.Cells(i, "A").Value = Cells(4, "D").Value And _
            sh.Cells(i, "G").Value = Cells(5, "D").Value And _
            sh.Cells(i, "H").Value = Cells(6, "D").Value Then
        sno = sno + 1
        Cells(sat, "A").Value = sno
        Cells(sat, "B").Value = sh.Cells(i, "E").Value
        sat = sat + 1
    End If
Next i
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[sahika51]

Teşekkür ederim. Tam istediğim gibi olmuş. Kullanım açısından daha kolay olması için, d4, d5 ve d6 daki listeler açıldığında sadeleşebilirmi, Örneğin 10. sınıf bir sürü var bunu teke düşürmek, Ders isimleri sadece bir kez öğretmen isimleri bir kez görünsün.

 

[Orion1]

Teşekkür ederim. Tam istediğim gibi olmuş. Kullanım açısından daha kolay olması için, d4, d5 ve d6 daki listeler açıldığında sadeleşebilirmi, Örneğin 10. sınıf bir sürü var bunu teke düşürmek, Ders isimleri sadece bir kez öğretmen isimleri bir kez görünsün.

Buyurun.

Sub aktarogrenci59()
Dim i As Long, sat As Long, sno As Long, sh As Worksheet
Dim sonsat As Long, deg As String, z As Object
Dim myarr(), n As Long
Sheets("Sayfa1").Select
Range("A10:R" & Rows.Count).ClearContents
Range("B10:E" & Rows.Count).UnMerge
Set sh = Sheets("Sheet1")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat = 10
ReDim myarr(1 To 2, 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 6 To sonsat
    deg = sh.Cells(i, "A").Value & sh.Cells(i, "G").Value & sh.Cells(i, "H").Value
    If sh.Cells(i, "A").Value = Cells(4, "D").Value And _
            sh.Cells(i, "G").Value = Cells(5, "D").Value And _
            sh.Cells(i, "H").Value = Cells(6, "D").Value Then
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = sh.Cells(i, "E").Value
        End If
    End If
Next i
If n > 0 Then
    Range("B10").Resize(n, 1) = Application.Transpose(myarr)
    For i = 10 To n + 9
        Range("B" & i & ":E" & i).Merge
        sno = sno + 1
        Cells(sat, "A").Value = sno
        sat = sat + 1
    Next i
End If
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[sahika51]

Orion son verdiğin kod sanki olmadı veya bende sıkıntı var. Eğer dosya şeklinde atabilirseniz sevinirim.

 

[Orion1]

Orion son verdiğin kod sanki olmadı veya bende sıkıntı var. Eğer dosya şeklinde atabilirseniz sevinirim.

Dosya ektedir.