A sayfasına gelen verileri B sayfasından kodlarını alma

[hsayar]

A sayfasının
ABCD Sütunları aşağıdaki gibidir
Not: Son satırı belli değildir.

2007	2007	Gıda	Ekmek
2007	2007	Gıda	Lokanta
2007	2007	Gıda	Market
2007	2007	Gıda	Pazar
2007	2007	Gıda	ekmek
2007	2007	Gıda	lokanta

B Sayfasının ABC sütunlarıda aşağıdaki gibidir.
Not: Kodlar A2:C69 aralığındadır.

901	Gıda	Market
902	Gıda	Pazar
903	Gıda	Ekmek
904	Gıda	Lokanta

makro çalıştıktıktan sonra
A sayfasının E sütununa kodlar ilave edilmiş olmalıdır?
ABCD Sütunları aşağıdaki gibidir

2007	2007	Gıda	Ekmek             903
2007	2007	Gıda	Lokanta           904
2007	2007	Gıda	Market            901
2007	2007	Gıda	Pazar               902  
2007	2007	Gıda	ekmek               903
2007	2007	Gıda	lokanta              904

gibi Yardımlarınız için teşekkürler

 

[accilisse]

böyle bir işlem için makroya gerek yok "ETOPLA" (SUMIF) formülü işini görecektir
ekli dosyayı inceleyiniz

 

[hsayar]

bana makro lazım hocam lakana teşekkür ederim.

 

[accilisse]

ekli dosyayı inceleyiniz,

 

[hsayar]

sn. accilisse teşekkür ederim bende biraz yalak kalınca uğraşarak çözdüm
sizin yazdığınız kodlar büyük küçük harf duyarlı bana duyarsızı lazımdı onuda bir fonksiyonla hallettim.

Private Sub Kodlar()
Dim wsTBL, wsKOD As Worksheet
        Set wsTBL = Sheets("TABLOM")
        Set wsKOD = Sheets("KODLAR")
        
If wsTBL.Cells(2, 1) = "" Then
    Rows(2).Delete
End If

sonsat = wsTBL.[a65536].End(3).Row
For sat = 2 To sonsat
yaz = ""
    If wsTBL.Cells(sat, "C") <> "" And wsTBL.Cells(sat, "D") <> "" Then
        For rpr = 1 To 69
            If UCaseTr(wsTBL.Cells(sat, "C")) = UCaseTr(wsKOD.Cells(rpr, "B")) And _
               UCaseTr(wsTBL.Cells(sat, "D")) = UCaseTr(wsKOD.Cells(rpr, "C")) Then
               yaz = wsKOD.Cells(rpr, "A")
            End If
        Next rpr
    Else
    End If
        wsTBL.Cells(sat, "e") = yaz
Next sat
End Sub



Function UCaseTr(ByVal metin As String)
    UCaseTr = UCase(Replace(Replace(metin, "&#305;", "I"), "i", "&#304;"))
End Function