Filtreye Göre Ürün Kodu

[randzafer]

Merheba üstadlar, ekteki excell dosyamda bir veri tablom var bir de liste tablom, veri tablomda yaklaşık 5 bin satırlık 3 kritere göre tanımlanmış ürünlerim ve bu ürünlere göre verilmiş kodlar var, istediğim şu örnek olarak liste tablosuna ekledim; liste tablosunda "Gender" , "Description" ya da "Common Categories" bölümlerine ilgili tanımlardan "Girl" " Knit" ya da "Tshirt" filtrelerinden birisini ya da aynı anda hepsini yazdığımda karşılığına gelen kodları yan tarafındaki "E" ve "F" sütunu alanlarına 1 ve 2 deki gibi biçimlendirilmiş ve numaralandırılmış haliyle gelmesi istiyorum. "B" sütunundaki alanları Metin kutusu gibi yapabilirsek çok güzel olur. Bir de hepsini yazmasam bile yani mesela sadece Description alanına da yazsam Common Categories alanına da yazsam kodları listelesin. Yardımlarınız için şimdiden teşekkürler.

 

[YUSUF44]

Aşağıdaki kodları ilgili sayfanın kod bölümüne yapıştırıp deneyiniz:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B4, B8, B12")) Is Nothing Then Exit Sub
Application.EnableEvents = False
eski = WorksheetFunction.Max(Cells(Rows.Count, "D").End(3).Row, 3)
Range("D3:F" & eski).Delete Shift:=xlUp

Set s2 = Sheets("Data")
son = s2.Cells(Rows.Count, "A").End(3).Row
        yeni = 3
For i = 2 To son
    If s2.Cells(i, "A") = [B4] And s2.Cells(i, "B") = [B8] And s2.Cells(i, "C") = [B12] Then
        Cells(yeni, "D") = yeni - 2
        Cells(yeni, "E") = s2.Cells(i, "D")
        Cells(yeni, "F") = s2.Cells(i, "E")
        yeni = yeni + 1
    End If
Next
    liste = Cells(Rows.Count, "D").End(3).Row
    Range("D3:F" & liste).Select
    With Selection.Font
        .Name = "Calibri"
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Font.Bold = False
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("C8").Select

Application.EnableEvents = True
End Sub

 

[randzafer]

Yusuf Bey merhaba zaman ayırdığınız için teşekkürler, list sayfasının üstünde Kod Görüntüle diyip yukarıdaki kodu yapıştırdım ama olmadı, modüle falan mı eklemem gerekiyor ya da nasıl bir işlem yapmam lazım yardımcı olursanız sevinirim teşekkürler.

 

[YUSUF44]

Bu kod sayfa olaylarına bağlı bir kod. Bu türden kodların çalışması için sayfada istenen/önceden belirlenen değişikliklerin yapılması gerekiyor. Ben de bu kodun çalışmasını

If Intersect(Target, Range("B4, B8, B12")) Is Nothing Then Exit Sub

kısmıyla B4, B8 ve B12 hücrelerinin değişmesine bağladım. Bu hücrelerde bir değişiklik yapıp, sonucu gözlemleyin.