Kurallı Kelime bulma

[leonadies]

Üstadlarım merhaba; A2 hücresinde yazan metni sütun isimlerinde yazan detaya göre metin içinde bulup yazmasını istiyorum. Kelime öbekleri arasında mutlaka virgül bulunuyor. İstediğim sonuçlar kırmızı ile yazdıklarımdır. Dosyasını da ekledim. Makro ile nasıl çözebilirim. Sütunlarda yazan isimlerin yerleri de değişebilir buna göre dinamik bir kurgu gerekmekte.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kod ile yapabilirsiniz.

Sub Test()
    Dim Bak As Range
    Dim Detay(3) As String
    Detay(0) = Range("B1").Value
    Detay(1) = Range("C1").Value
    Detay(2) = Range("D1").Value
    Detay(3) = Range("E1").Value
    
    Dim Renkler() As String
    Dim Renk As String
    Dim Sira As Integer
    
    For Each Bak In Range("A2:A" & Cells(Rows.Count, "A").End(3).Row)
        Renkler = Split(Bak, ",")
        For Sira = 0 To UBound(Detay)
            With WorksheetFunction
                Renk = Trim(Right(Renkler(Sira), Len(Renkler(Sira)) - .Find(";", Renkler(Sira))))
                Cells(Bak.Row, Sira + 2) = Renk
            End With
        Next
    Next
End Sub

Yalnız A sütununda bulunan renk detaylarının sıralaması ile B, C, D, E sütunlarındaki sıralama aynı olmalı. Eğer farklı olma ihtimali varsa söyleyin kodları ona göre revize edeyim.

 

[leonadies]

Aslında sabit tutmaya odakliyim. Ancak duruma gore değişkenlik yasayabilirim. Bu yapida sütun başında yazan kelimelere odaklı dinamik bir yapıda olursa harika olur ustadim

 

[Muzaffer Ali]

O zaman aşağıdaki kodu kullanın.

Sub Test()
    Dim Bak As Range
    Dim Detay As Range

    Dim Renkler() As String
    Dim Renk As String
    Dim Sira As Integer

    For Each Bak In Range("A2:A" & Cells(Rows.Count, "A").End(3).Row)
        Renkler = Split(Bak, ",")
        For Sira = 0 To UBound(Renkler)
            For Each Detay In Range("B1:E1")
                With WorksheetFunction
                    If Detay = Trim(Left(Renkler(Sira), .Find(";", Renkler(Sira)) - 1)) Then
                        Renk = Trim(Right(Renkler(Sira), Len(Renkler(Sira)) - .Find(";", Renkler(Sira))))
                        Cells(Bak.Row, Detay.Column) = Renk
                    End If
                End With
            Next
        Next
    Next
End Sub

 

[leonadies]

Süper olmuş Ellerine sağlık üstadım İstediğim kadar sütun ve satırda çalışıyor