malzemenin fiyatının benzersiz olduğu yerleri listelemek

[modoste]

merhaba sayın hocalarım
daha önce sorduğum ve makrolu çözüm üretilen çalışmada bir detay daha ekleyerek yeniden sordum. Ekli dosyada açıklamaları belirttim

önceki çalışma çözümü sarı dolgulu yerde ve yeni istediğim makrolu çözümü de yeşil dolgulu alanda yapılmasını istemekteyim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Dizi As Object, Veri As Variant, X As Long, Sutun As Integer, Say As Long
    
    If Intersect(Target, Range("J1:J3")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")

    Range("K3:XFD7").Clear
    ReDim Liste(1 To 5, 1 To 1000)
    Veri = Range("B4").CurrentRegion.Value

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 2) = Range("J3").Value Then
            If Veri(X, 1) >= Range("J1").Value And Veri(X, 1) <= Range("J2").Value Then
                If Not Dizi.Exists(Veri(X, 2) & "|" & Veri(X, 5)) Then
                    Say = Say + 1
                    Dizi.Add Veri(X, 2) & "|" & Veri(X, 5), Say
                    Sutun = Sutun + 1
                    Liste(1, Sutun) = Veri(X, 1)
                    Liste(2, Sutun) = Veri(X, 4)
                    Liste(3, Sutun) = Veri(X, 3)
                    Liste(4, Sutun) = Veri(X, 5)
                    Liste(5, Sutun) = Veri(X, 6)
                End If
            End If
        End If
    Next

    If Sutun > 0 Then
        Range("K3").Resize(5, Sutun) = Liste
        Cells.Font.Name = "Tahoma"
        Cells.Font.Size = 7
        Columns.AutoFit
        Application.ScreenUpdating = True
    Else
        Application.ScreenUpdating = True
        MsgBox "Aranan malzeme bulunamadı!", vbCritical
    End If
    
    Set Dizi = Nothing
End Sub

 

[modoste]

sayın Korhan hocam
uyguladım şimdi.
teşekkür ederim