Makro arıyor buluyor veri yazıyor ama bulamadıkları ?

[eneskus]

Ustalarım Aşağıdaki kod ile bir sayfadaki verileri başka bir sayfada arayıp bulup veri aktarmakta ancak bulamadığı veriler için

bulamadığı veri sayfasındaki verinin satırını sarıya
bulamadığı veri sayfasındaki verinin bulunduğu hüçreyi maviye boyamamız mümkünmü acaba

VERİ_DOSYASINDAKİ_YENİ_MALZEMELERİ_YENİ_MALZEME_MUTABAKATINA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte
    Dim BUL_MALZEME As Range, BUL_NO As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
 
    S2.Range("D45:GL1244").ClearContents
 
    For X = 2 To 1201
        For Y = 27 To 37 Step 2
            If S1.Cells(X, Y) <> "" Then
                Set BUL_MALZEME = S2.Rows("4:4").Find(S1.Cells(X, Y), , xlValues)
                If Not BUL_MALZEME Is Nothing Then
                    Set BUL_NO = S2.Range("A43:A1244").Find(S1.Cells(X, 1), , , xlWhole)
                    If Not BUL_NO Is Nothing Then
                        S2.Cells(BUL_NO.Row, BUL_MALZEME.Column) = S1.Cells(X, Y + 1)
                    End If
                End If
            End If
            Set BUL_MALZEME = Nothing
            Set BUL_NO = Nothing
        Next
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
End Sub

 

[Huseyinkis]

ekteki kodları bir denermisiniz. Dosya olmadan yapmak biraz karışık oluyor yanlış olabilir.

Sub VERİ_DOSYASINDAKİ_YENİ_MALZEMELERİ_YENİ_MALZEME_MUTABAKATINA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte
    Dim BUL_MALZEME As Range, BUL_NO As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
 
    S2.Range("D45:GL1244").ClearContents
 
    For X = 2 To 1201
        For Y = 27 To 37 Step 2
            If S1.Cells(X, Y) <> "" Then
                Set BUL_MALZEME = S2.Rows("4:4").Find(S1.Cells(X, Y), , xlValues)
                       If Not BUL_MALZEME Is Nothing Then
                    Set BUL_NO = S2.Range("A43:A1244").Find(S1.Cells(X, 1), , , xlWhole)
                          If Not BUL_NO Is Nothing Then
                        S2.Cells(BUL_NO.Row, BUL_MALZEME.Column) = S1.Cells(X, Y + 1)
                    S1.Cells(X, Y).Interior.Color = vbyellow
                     Else
            S1.Cells(X, Y).Interior.Color = vbBlue
                    End If
                End If
                End If
            Set BUL_MALZEME = Nothing
            Set BUL_NO = Nothing
        Next
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
End Sub

 

[eneskus]

İlginiz için teşekkürler ancak aktardığı verileri yani bulunan verileri sarıya boyamaktadır.

 

[Huseyinkis]

İlginiz için teşekkürler ancak aktardığı verileri yani bulunan verileri sarıya boyamaktadır.

S1.Cells(X, Y).Interior.Color = vbYellow bunu silin.

Else
S1.Cells(X, Y).Interior.Color = vbBlue
end if

kısmınıda

Else
S1.Rows(X).Interior.Color = vbYellow
S1.Cells(X, Y).Interior.Color = vbBlue
end if

olarak değiştirin.

 

[eneskus]

Örnek dosya eklemekteyim.
makro aktarma sonrası sarı olması gereken hüçreleri sarı renge boyadım
makro
Veri sayfasından malzeme ismini yeni mal. mut. dosyası 4:4 de aramakta bulunca a45:a1244 arası sıra numarasına bakmakta ve veri sayfasındaki malzeme isminin sağındaki adedi yeni mal. mut sayfasında bulduğu sütun ve sıra numarası kesişimine yazmakta.

Malzeme ismini bulamazsa bulamadıuğı malzeme ismini sarıya boyasın.

 

[Huseyinkis]

Örnek dosya eklemekteyim.
makro aktarma sonrası sarı olması gereken hüçreleri sarı renge boyadım
makro
Veri sayfasından malzeme ismini yeni mal. mut. dosyası 4:4 de aramakta bulunca a45:a1244 arası sıra numarasına bakmakta ve veri sayfasındaki malzeme isminin sağındaki adedi yeni mal. mut sayfasında bulduğu sütun ve sıra numarası kesişimine yazmakta.

Malzeme ismini bulamazsa bulamadıuğı malzeme ismini sarıya boyasın.

Ekteki kodları denermisiniz.

Sub VERİ_DOSYASINDAKİ_YENİ_MALZEMELERİ_YENİ_MALZEME_MUTABAKATINA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte
    Dim BUL_MALZEME As Range, BUL_NO As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YENİ MAL. MUT.")
 
    S2.Range("D45:GL1244").ClearContents
 
    For X = 2 To 1201
        For Y = 27 To 37 Step 2
            If S1.Cells(X, Y) <> "" Then
                Set BUL_MALZEME = S2.Rows("4:4").Find(S1.Cells(X, Y), , xlValues)
                If Not BUL_MALZEME Is Nothing Then
                    Set BUL_NO = S2.Range("A43:A1244").Find(S1.Cells(X, 1), , , xlWhole)
                    If Not BUL_NO Is Nothing Then
                        S2.Cells(BUL_NO.Row, BUL_MALZEME.Column) = S1.Cells(X, Y + 1)
                    Else
                    S1.Cells(X, Y).Interior.Color = vbYellow
                    End If
                    Else
                    S1.Cells(X, Y).Interior.Color = vbYellow
                  End If
            End If
            Set BUL_MALZEME = Nothing
            Set BUL_NO = Nothing
        Next
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
End Sub

 

[eneskus]

Huseyinkis teşekkür ederim kodlar çalışıyor.