Uygun olmayan veride ne yapilmasi gerektigi önemli eger bir sey yapilmazsa onceden girilmis degerler korunur ve siz bunun farkına bile varmazsınız
Ayrıca diyelim ki L sütununda var olan çatı kelimesini batı yada elma ile değiştirdiğinizde ne olacak

yani bilemedim. ne önerirsiniz?

Buna karar verecek olan sizsiniz
Bir çok olası hata mevcut
1 - mesela B sütununa girilen değer L sütununda olmayabilir
2 - C yada M sütununa girilen ifade sayisal olmayabilir
3 - hata olmamakla beraber L sütunundaki ifade değiştirildiğinde ne yapılacağı belirsiz mesela L sütununda MEMBRAN ifadesi ZAMRAN olarak değiştirildi bu durumda ne yapılacağı yine belirsiz
Ve bu durumlarda ne yapılacağı yine belirsiz!

şimdilik sadece B ve C sütunları için
hata durumunda ilgili satırın B hücresinin rengi kırmızı oluyor.
Mesela: B sütununda "TEMEL BETON"  yazarken L sütununda "TEMEL BETON " yani L'de en sonda fazladan boşluk var
çalışmanızda L sütunu ile B sütunundaki verileri eşleştirirken dikkatli olun dikkatten kaçan fazladan bir boşluk hataya sebebep oluyor mesela
1 - bir modul oluşturup aşağıdaki kodları yapıştırın

Option Compare Text



Function xHesapla(ByVal Rng As Range) ' As String

xRng = WorksheetFunction.Trim(Rng.Value)

xRef = VLookupFonksiyonu(Rng.Worksheet, Rng) 'xB_Dict(xRng)

xBDgr = IIf(xRng = "MEMBRAN", 100, 75)

xCDgr = Rng.Offset(, 1)

If Not IsNumeric(xCDgr) Then xCDgr = 0: Rng.Offset(, 1).Interior.Color = vbRed Else Rng.Offset(, 1).Interior.Color = xlNone



xRow = Rng.Row

Rng.Offset(, 3) = xCDgr * xRef 'E

Rng.Offset(, 4) = xCDgr * xRef * (xBDgr / 100) 'F

Rng.Offset(, 5).Formula = "=F" & xRow & "+ G" & xRow - 1  'G

Rng.Offset(, 6) = xCDgr * xRef * ((100 - xBDgr) / 100) 'H



End Function



Function VLookupFonksiyonu(Sht As Worksheet, ByVal Rng As Range)

On Error GoTo hata

Dim xMDgr As Double

 xDgr = WorksheetFunction.Trim(Rng.Value)

xMDgr = WorksheetFunction.VLookup(xDgr, Sht.Range("L:M"), 2, 0)

hata:

If Err.Number = 1004 Then xMDgr = 0: Rng.Interior.Color = vbRed Else Rng.Interior.Color = xlNone

VLookupFonksiyonu = xMDgr

End Function

2 - işlem görülecek sayfanın  Worksheet_Change olayının kodu

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("B:C")) Is Nothing Then 'sadece B,C sütununa bakar

Application.EnableEvents = False

    On Error GoTo hata

    Dim cll As Range

    AdrX = Target.Address & ":" & Target.Address

    xDz = Split(AdrX, "$")

    ilk = xDz(2)

    Son = Val(xDz(4))



    If ilk = "1:" Then ilk = "2:"

    If Son < 2 Then Son = 2

    Set Trgt = Range("B" & ilk & "B" & Son)



    For Each cll In Trgt

        Set Rng = cll

        xHesapla (Rng)

    Next cll



End If

hata:

Application.EnableEvents = True

End Sub

(04/01/2022, 23:16)berduş yazdı: şimdilik sadece B ve C sütunları için
hata durumunda ilgili satırın B hücresinin rengi kırmızı oluyor.
Mesela: B sütununda "TEMEL BETON"  yazarken L sütununda "TEMEL BETON " yani L'de en sonda fazladan boşluk var
çalışmanızda L sütunu ile B sütunundaki verileri eşleştirirken dikkatli olun dikkatten kaçan fazladan bir boşluk hataya sebebep oluyor mesela
1 - bir modul oluşturup aşağıdaki kodları yapıştırın

Option Compare Text



Function xHesapla(ByVal Rng As Range) ' As String



xRef = VLookupFonksiyonu(Rng.Worksheet, Rng) 'xB_Dict(xRng)

xBDgr = IIf(xRng = "MEMBRAN", 100, 75)

xCDgr = Rng.Offset(, 1)

xRow = Rng.Row

Rng.Offset(, 3) = xCDgr * xRef 'E

Rng.Offset(, 4) = xCDgr * xRef * (xBDgr / 100) 'F

Rng.Offset(, 5).Formula = "=F" & xRow & "+ G" & xRow - 1  'G

Rng.Offset(, 6) = xCDgr * xRef * ((100 - xBDgr) / 100) 'H



End Function



Function VLookupFonksiyonu(Sht As Worksheet, ByVal Rng As Range)

On Error GoTo hata

Dim xMDgr As Double

 xDgr = WorksheetFunction.Trim(Rng.Value)

xMDgr = WorksheetFunction.VLookup(xDgr, Sht.Range("L:M"), 2, 0)

hata:

If Err.Number = 1004 Then xMDgr = 0: Rng.Interior.Color = vbRed Else Rng.Interior.Color = xlNone

VLookupFonksiyonu = xMDgr

End Function

2 - işlem görülecek sayfanın  Worksheet_Change olayının kodu

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("B:C")) Is Nothing Then 'sadece B,C sütununa bakar

Application.EnableEvents = False

    On Error GoTo hata

    Dim cll As Range

    AdrX = Target.Address & ":" & Target.Address

    xDz = Split(AdrX, "$")

    ilk = xDz(2)

    Son = Val(xDz(4))



    If ilk = "1:" Then ilk = "2:"

    If Son < 2 Then Son = 2

    Set Trgt = Range("B" & ilk & "B" & Son)



    For Each cll In Trgt

        Set Rng = cll

        xHesapla (Rng)

    Next cll



End If

hata:

Application.EnableEvents = True

End Sub

şahane.. Teşekkür ederim. ellerinize sağlık. sadece membran gördüğünde %75 değil tamamını alması gerekiyordu onuda kodları kurcalayayım biraz çözerim belki.

kodu yeniden düzenledim eklerken bir satırı yanlışlıkla silmişim
xHesapla fonksiyonun en üst satırında

xRng = WorksheetFunction.Trim(Rng.Value)

kodu olmalıydı

---

ayrıca C sütununa sayısal veri girilmemişse onun için de hata kodu eklendi