Aranan Sayılara Ait Tarihlerin Alınması

[1Al2Ver]

Merhaba,

"Süz" sayfası Q2:V2 aralığına sayılar yazıyorum ( en fazla 6 sütun )

Bu sayılar bazen 2, bazen fazla oluyor ( Q2 ve R2, bazen Q2, R2 ve S2, bazen Q2, R2, ve T2 vb. gibi)

İsteğim ; Q2:V2 aralığına girdiğim sayıları "Sheet1" sayfasında, D2:K2000 aralığındaki verilerde arayıp, "Süz" sayfası, O220 aralığına getirmesi.

Teşekkür ederim.

 

[Asri]

SÜZ sayfasının kod bölümüne ekleyerek deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [Q2:V2]) Is Nothing Then Exit Sub
    Set shsuz = Sheets("SÜZ")
    Set shliste = Sheets("Sheet1")
    suzsonsatir = shsuz.Cells(Rows.Count, "O").End(3).Row
    If suzsonsatir > 1 Then shsuz.Range("O2:P" & suzsonsatir).Clear
    listesonsatir = shliste.Cells(Rows.Count, "D").End(3).Row
    suzsayilar = shsuz.Cells(2, "Q") & "/" & shsuz.Cells(2, "R") & "/" & shsuz.Cells(2, "S") & "/" & shsuz.Cells(2, "T") & "/" & shsuz.Cells(2, "U") & "/" & shsuz.Cells(2, "V")
    satir = 1
    For i = 2 To listesonsatir
     listesayilar = ""
     If shsuz.Cells(2, "Q") = "" Then listesayilar = listesayilar & "/" Else listesayilar = listesayilar & shliste.Cells(i, "F") & "/"
     If shsuz.Cells(2, "R") = "" Then listesayilar = listesayilar & "/" Else listesayilar = listesayilar & shliste.Cells(i, "G") & "/"
     If shsuz.Cells(2, "S") = "" Then listesayilar = listesayilar & "/" Else listesayilar = listesayilar & shliste.Cells(i, "H") & "/"
     If shsuz.Cells(2, "T") = "" Then listesayilar = listesayilar & "/" Else listesayilar = listesayilar & shliste.Cells(i, "I") & "/"
     If shsuz.Cells(2, "U") = "" Then listesayilar = listesayilar & "/" Else listesayilar = listesayilar & shliste.Cells(i, "J") & "/"
     If shsuz.Cells(2, "V") = "" Then listesayilar = listesayilar Else listesayilar = listesayilar & shliste.Cells(i, "K")
     
     If suzsayilar = listesayilar Then
        satir = satir + 1
        shsuz.Cells(satir, "O").Value = shliste.Cells(i, "D")
        shsuz.Cells(satir, "P").Value = shliste.Cells(i, "E")
     End If
    Next i
    shsuz.Columns("P:P").Select
    Selection.NumberFormat = "m/d/yyyy"
    shsuz.Range("P2").Select
End Sub

 

[1Al2Ver]

Sayın Asri, merhaba,

Elinize sağlık, çok teşekkür ederim.

Saygılarımla.

 

[1Al2Ver]

Sayın Asri tekrar merhaba,

Çok önemli değil ama,

1) O ve P sütununun fontunu değiştirsem bile ( Calibri 10 ) kod ( şu haliyle Arial 11 ) tekrar eski haline getiriyor, istediğim fontu yazdığımda, kod fontu bozmasın, istiyorum.

2) Kod'u butona bağlamak istersem ne yapmalıyım ?

Teşekkür ederim.

 

[Ömer]

Merhaba,

Alternatif:

Sub Ara_Bul()
    
    Dim i As Long, SS As Worksheet, say As Long, sat As Long

    Set SS = Sheets("Sheet1")
    
    Application.ScreenUpdating = False
    Sheets("SÜZ").Select
    Range("O2:P" & Rows.Count).ClearContents
    
    If WorksheetFunction.Count(Range("Q2:V2")) = 0 Then Exit Sub

    say = Evaluate("=Dcount(Sheet1!F:K,,Q1:V2)")
    
    For i = 1 To say
        sat = Evaluate("=SMALL(IF(MMULT((0+(IF(Q2:V2="""",1," & _
            "Sheet1!F2:K2000=Q2:V2))),{1;1;1;1;1;1})=6," & _
            "ROW(Sheet1!F2:K2000))," & i & ")")
        Cells(i + 1, "O") = SS.Cells(sat, "D")
        Cells(i + 1, "P") = SS.Cells(sat, "E")
    Next i
      
End Sub

.

 

[1Al2Ver]

Sayın Ömer merhaba,

İlginiz ve alternatif çözümünüz için teşekkür ederim.

Saygılarımla.