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