Çözüldü Makro ile duseyara yaptigim hucrelerdeki veriler ile reklerinde gelmesini saglayan kod

[maratikkral]

Merhaba
Asagidaki Linkteki excel dosyasinda ;
Sheet1 sayfasinda A kolonunda bulunan verilerin RT Req Log logundan duseyara ile B,C,D,E Kolonlarina gelecek olan verilerin renkleri ile gelmesi icin yardimlarinizi bekliyorum.

excel dosyasi

 

[Korhan Ayhan]

Merhaba,

Deneyiniz.

Option Explicit

Sub Vlookup_Format_Color()
    Dim My_Rng As Range, Search_Data As String
    Dim Tbl_Area As String, My_Column As Integer, Rng As Range
    Dim Find_Data As Range, Split_Formula As Variant
    
    Application.ScreenUpdating = False
    
    Selection.Interior.Color = xlNone
    
    For Each My_Rng In Selection
        If InStr(1, My_Rng.Formula, "VLOOKUP") > 0 Then
            Split_Formula = Replace(Replace(My_Rng.Formula, "=IFERROR(", ""), "),""-""", "")
            Split_Formula = Replace(Replace(Split_Formula, "VLOOKUP(", ""), ",0)", ",0")
            Search_Data = Split(Split_Formula, ",")(0)
            Tbl_Area = Split(Split_Formula, ",")(1)
            My_Column = Split(Split_Formula, ",")(2)
            On Error Resume Next
            Set Rng = Nothing
            Set Rng = Range(Search_Data)
            On Error GoTo 0
            If Not Rng Is Nothing Then
                Set Find_Data = Range(Tbl_Area).Find(Rng.Value, , , xlWhole)
                If Not Find_Data Is Nothing Then My_Rng.Interior.Color = Find_Data.Offset(0, My_Column - 1).Interior.Color
            Else
                Set Find_Data = Range(Tbl_Area).Find(Evaluate(Search_Data), , xlValues, xlWhole)
                If Not Find_Data Is Nothing Then My_Rng.Interior.Color = Find_Data.Offset(0, My_Column - 1).Interior.Color
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[maratikkral]

Merhaba,

Deneyiniz.

Option Explicit

Sub Vlookup_Format_Color()
    Dim My_Rng As Range, Search_Data As String, Tbl_Area As String
    Dim My_Column As Integer, Rng As Range, Find_Data As Range
   
    Application.ScreenUpdating = False
   
    Selection.Interior.Color = xlNone
   
    For Each My_Rng In Selection
        If Left(My_Rng.Formula, 8) = "=VLOOKUP" Then
            Search_Data = Replace(Split(Split(My_Rng.Formula, "(")(1), ",")(0), """", "")
            Tbl_Area = Split(Split(My_Rng.Formula, "(")(1), ",")(1)
            My_Column = Split(Split(My_Rng.Formula, "(")(1), ",")(2)
            On Error Resume Next
            Set Rng = Nothing
            Set Rng = Range(Search_Data)
            On Error GoTo 0
            If Not Rng Is Nothing Then
                Set Find_Data = Range(Tbl_Area).Find(Rng.Value, , , xlWhole)
                If Not Find_Data Is Nothing Then My_Rng.Interior.Color = Find_Data.Offset(0, My_Column - 1).Interior.Color
            Else
                Set Find_Data = Range(Tbl_Area).Find(Search_Data, , xlValues, xlWhole)
                If Not Find_Data Is Nothing Then My_Rng.Interior.Color = Find_Data.Offset(0, My_Column - 1).Interior.Color
            End If
        End If
    Next
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

yardimlariniz icin tesekkur ederim.Denedigimde sadece ilk satirdaki 4 sutunun rengini dogru getiriyor ve digerlerinede aynisini uyguluyor ve sadece ilk satirdaki 4 sutun dogru olmus oluyor.

 

[Korhan Ayhan]

Merhaba,

Paylaştığınız dosyada ilk satırdaki formüllerle alt satırdaki formüller aynı olduğu için sonuç hatalıymış gibi görünüyor. Bu haliyle formülü revize edince kod doğru sonuç vermeyecektir. Birazdan düzenler yeniden paylaşırım.

 

[Korhan Ayhan]

#2 nolu mesajımdaki kodu revize ettim. Ayrıca dosyanızdaki formülüde revize ettim. Örnek dosyanızda aynı mesaj ekindedir.

 

[maratikkral]

Tesekkur ederim emeginize saglik Korhan Bey