Satır ve Sütunda arayıp kesişim hücresi işaretleme

[velostar]

İyi günler, ekli dosyada Ders sayfası bilgilerini webden alıyorum. Yapmak istediğim seçmeli 20 dersten seçilen 9 dersi Secim sayfasındaki tabloya "x" harfi koyarak işaretlemek. TC ye göre arattırıp derslerden sadece birisini işaretlettirebiliyorum ancak birden çok dersi işaretletmek konusu beni aştı. Yardımcı olabilirseniz çok çok hayra geçer. Şimdiden teşekkürler.

 

[Mahir64]

Merhaba,
Formülle bir çözüm isterseniz deneyin.

=EĞER(TOPLA.ÇARPIM((Ders!$D$2:$D$20=$X2)*--(Ders!$H$2:$P$20=D$1))>0;"X";"")

 

[velostar]

Merhaba,
Formülle bir çözüm isterseniz deneyin.

=EĞER(TOPLA.ÇARPIM((Ders!$D$2:$D$20=$X2)*--(Ders!$H$2:$P$20=D$1))>0;"X";"")

3000 den fazla öğrenci ismi olduğu için formül kullanamıyorum maalese, ama deneme yapabilmem için bir başlangıç noktası olabilir. Çok teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Ders_Secimlerini_Aktar()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Y As Integer, Son As Long, Ders_Say As Long
    Dim Ders As Variant, Say As Long, Bul As Integer, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Secim")
    Set S2 = Sheets("Ders")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S1.Range("D2:W" & S1.Rows.Count).ClearContents
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S2.Range("A2:P" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Dizi.Item(Veri(X, 4)) = Join(Application.Index(Veri, X, _
        Application.Transpose([Row(8:16)])), "|")
    Next

    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = S1.Range("X2:X" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 20)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Ders = Split(Dizi.Item(Veri(X, 1)), "|")
            For Y = LBound(Ders) To UBound(Ders)
                If Ders(Y) <> "" Then
                    Ders_Say = Ders_Say + 1
                    Bul = Application.Match(Ders(Y), S1.Range("D1:W1"), 0)
                    Liste(Say, Bul) = "X"
                End If
            Next
        End If
    Next

    If Ders_Say = 0 Then
        MsgBox "Seçim yapılmış ders bulunamadı!", vbExclamation
    Else
        S1.Range("D2").Resize(Say, 20) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[velostar]

Deneyiniz.

Option Explicit

Sub Ders_Secimlerini_Aktar()
    Dim Dizi As Object, S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Y As Integer, Son As Long, Ders_Say As Long
    Dim Ders As Variant, Say As Long, Bul As Integer, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Secim")
    Set S2 = Sheets("Ders")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    S1.Range("D2:W" & S1.Rows.Count).ClearContents
   
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
   
    Veri = S2.Range("A2:P" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Dizi.Item(Veri(X, 4)) = Join(Application.Index(Veri, X, _
        Application.Transpose([Row(8:16)])), "|")
    Next

   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
   
    Veri = S1.Range("X2:X" & Son).Value
   
    ReDim Liste(1 To UBound(Veri, 1), 1 To 20)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Ders = Split(Dizi.Item(Veri(X, 1)), "|")
            For Y = LBound(Ders) To UBound(Ders)
                If Ders(Y) <> "" Then
                    Ders_Say = Ders_Say + 1
                    Bul = Application.Match(Ders(Y), S1.Range("D1:W1"), 0)
                    Liste(Say, Bul) = "X"
                End If
            Next
        End If
    Next

    If Ders_Say = 0 Then
        MsgBox "Seçim yapılmış ders bulunamadı!", vbExclamation
    Else
        S1.Range("D2").Resize(Say, 20) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

çok teşekkürler, Ben de arada Mahir Bey'in verdiği formülü uygulatıp formülden çıkararak oldukça meşakatli bir yol izlemiştim. Emeğinize sağlık.