• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

En avantajlı Birim fiyat bulurken 0 "Sıfır" dahil etmeme

sirkülasyon

sirkülasyon

Altın Üye
Katılım
10 Temmuz 2012
Mesajlar
2,543
Excel Vers. ve Dili
2021 LTSC TR
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set Alan = Union(Range("F64"), Range("H64"), Range("J64"), Range("L64"))
    
    Fiyat_1 = Format(WorksheetFunction.Small(Alan, 1), "#,##0.00")
    Fiyat_2 = Format(WorksheetFunction.Small(Alan, 2), "#,##0.00")
    
    For Each Veri In Alan
        If Veri.Value = CDbl(Fiyat_1) Then
            Range("D68") = Cells(11, Veri.Column - 1)
            Range("G68") = Cells(12, Veri.Column - 1)
            Range("K68") = CDbl(Fiyat_1)
            Range("D70") = Cells(11, Veri.Column - 1)
            Range("G70") = Cells(12, Veri.Column - 1)
            Range("K70") = CDbl(Fiyat_1)
        End If
        
        If Veri.Value = CDbl(Fiyat_2) Then
            Range("D69") = Cells(11, Veri.Column - 1)
            Range("G69") = Cells(12, Veri.Column - 1)
            Range("K69") = CDbl(Fiyat_2)
        End If
    Next
    
    Set Alan = Nothing
End Sub

Yukarıda yer alan kod Korhan abime ait bir kod.
Lakin en düşük firmayı bulunca 0 "Sıfır" olan toplamları da dahil ediyor. Bu kodu sıfırları dahil etmeyecek şekilde düzenleyebilir miyiz?
Teşekkür eder, saygılarımı sunarım
 
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set Alan = Union(Range("F64"), Range("H64"), Range("J64"), Range("L64"))
    
    Fiyat_1 = Format(WorksheetFunction.Small(Alan, 1), "#,##0.00")
    Fiyat_2 = Format(WorksheetFunction.Small(Alan, 2), "#,##0.00")
    
    For Each Veri In Alan
[B][COLOR="Red"]    If Veri.Value = 0 Then GoTo devam[/COLOR][/B]
        If Veri.Value = CDbl(Fiyat_1) Then
            Range("D68") = Cells(11, Veri.Column - 1)
            Range("G68") = Cells(12, Veri.Column - 1)
            Range("K68") = CDbl(Fiyat_1)
            Range("D70") = Cells(11, Veri.Column - 1)
            Range("G70") = Cells(12, Veri.Column - 1)
            Range("K70") = CDbl(Fiyat_1)
        End If
        
        If Veri.Value = CDbl(Fiyat_2) Then
            Range("D69") = Cells(11, Veri.Column - 1)
            Range("G69") = Cells(12, Veri.Column - 1)
            Range("K69") = CDbl(Fiyat_2)
        End If
[B][COLOR="Red"]devam:[/COLOR][/B]
    Next
    
    Set Alan = Nothing
End Sub
şeklinde deneyiniz.
 
Sayın antonio
Kodda yapmış olduğunuz değişiklik sıfırı dahil etmiyor.
Ancak ikinci en avantajlı olan firmaya ait tutarı işleme almıyor.
 
O halde şöyle deneyin:
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set Alan = Union(Range("F64"), Range("H64"), Range("J64"), Range("L64"))
     
    Fiyat_1 = Format(WorksheetFunction.Small(Alan, 1), "#,##0.00")
    Fiyat_2 = Format(WorksheetFunction.Small(Alan, 2), "#,##0.00")
    
    For Each Veri In Alan
        If Veri.Value = CDbl(Fiyat_1) And Veri.Value > 0 Then
            Range("D68") = Cells(11, Veri.Column - 1)
            Range("G68") = Cells(12, Veri.Column - 1)
            Range("K68") = CDbl(Fiyat_1)
            Range("D70") = Cells(11, Veri.Column - 1)
            Range("G70") = Cells(12, Veri.Column - 1)
            Range("K70") = CDbl(Fiyat_1)
        End If
        
        If Veri.Value = CDbl(Fiyat_2) And Veri.Value > 0 Then
            Range("D69") = Cells(11, Veri.Column - 1)
            Range("G69") = Cells(12, Veri.Column - 1)
            Range("K69") = CDbl(Fiyat_2)
        End If
    Next
    
    Set Alan = Nothing
End Sub
 
Üstad
bu sefer en avantajlı birinci firmayı ikinci en avantajlı firma yaptı

Dosya ekli yardımcı olabilirseniz sevinirim
 

Ekli dosyalar

Yazdığınız kodların üzerinden düzenleme yapmakla sağlıklı bir sonuca ulaşmak biraz zor gibi görünüyor.
 
Kodlar bana değil Korhan uzmanıma ait kod
Ayrıca yardımlarınız içinde teşekkür ederim.
Belki başka bir uzmanımız görür de yardımcı olur.
 
Merhaba

Değeri sıfır olan hücrelerin, döngü ile aranacak alandan çıkarılması daha uygun görünüyor
ve en küçük değerde iki adet olma ihtimali gözönüne alınarak; aşağıdaki gibi denermisiniz,
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Alan, a, veri As Range
Dim n, s As String
Dim Fiyat_1, Fiyat_2 As String
n = Empty
Set Alan = Union(Range("F64"), Range("H64"), Range("J64"), Range("L64"))
For Each a In Alan
If Format(a.Value, "#,##0.00") <> 0 Then s = s & "," & a.Address
Next
If UBound(Split(s, ",")) > 0 Then
Fiyat_1 = Format(WorksheetFunction.Small(Range(Right(s, Len(s) - 1)), 1), "#,##0.00")
If UBound(Split(s, ",")) > 1 Then _
Fiyat_2 = Format(WorksheetFunction.Small(Range(Right(s, Len(s) - 1)), 2), "#,##0.00")
    For Each veri In Alan
        If veri.Value = CDbl(Fiyat_1) And n = Empty Then
        n = veri.Address
            Range("D68") = Cells(11, veri.Column - 1)
            Range("G68") = Cells(12, veri.Column - 1)
            Range("K68") = CDbl(Fiyat_1)
            Range("D70") = Cells(11, veri.Column - 1)
            Range("G70") = Cells(12, veri.Column - 1)
            Range("K70") = CDbl(Fiyat_1)
        End If
        If Fiyat_2 <> "" Then
        If veri.Value = CDbl(Fiyat_2) and n <> veri.Address Then
            Range("D69") = Cells(11, veri.Column - 1)
            Range("G69") = Cells(12, veri.Column - 1)
            Range("K69") = CDbl(Fiyat_2)
        End If: End If
    Next
If Fiyat_2 = "" Then MsgBox "Avantajlı 1 Adet bulundu", vbCritical
    End If
Set Alan = Nothing
End Sub
 
Son düzenleme:
Sayın PLİNT
Yardımcı olduğunuz ve düzenlediğiniz kod ile talebim gerçekleşti.
Teşekkür ederim. Sağol
 
sirkülasyon' Alıntı:
Sayın PLİNT
Yardımcı olduğunuz ve düzenlediğiniz kod ile talebim gerçekleşti.
Teşekkür ederim. Sağol
Genişletmek için tıkla ...
Rica ederim, güle güle kullanın.
Dosyanızı inceleme imkanım yok ama en küçük değerden iki adet ten fazla
olma ihtimali varsa kodlara eklemeler gerekecektir, mesela "f64" =0, "H64"=1
"J64"=1 ,"L64"=1 gibi olduğunda "H64" ve "L64" hücrelerini baz alacak "J64"ü atlayacaktır. Saygılarımla.
 
SAYIN PLİNT
bahsettiğiniz olay hiç aklıma gelmedi, böyle birşey ile de karşılaşmadım.
Böyle bir şeyin olması durumunda nasıl bir kod ya da işlem yapmamız lazım gelir?
 
sirkülasyon' Alıntı:
SAYIN PLİNT
bahsettiğiniz olay hiç aklıma gelmedi, böyle birşey ile de karşılaşmadım.
Böyle bir şeyin olması durumunda nasıl bir kod ya da işlem yapmamız lazım gelir?
Genişletmek için tıkla ...

Aşağıdaki gibi ekleme yaparsanız ilk iki küçük sayıyı bulduğunda sonrakilere
bakmayacaktır.

http://s3.dosya.tc/server9/6g1wpd/deneme.zip.html

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Alan, a, veri As Range
[COLOR="Red"]Dim Bak As Integer
    On Error Resume Next
    For Bak = 14 To 63
        
        Range("F" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("E" & Bak))
        Range("H" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("G" & Bak))
      Range("K" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("I" & Bak))
      Range("L" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("K" & Bak))[/COLOR]
Dim n, [COLOR="Red"]j,[/COLOR] s As String
Dim Fiyat_1, Fiyat_2 As String
n = Empty[COLOR="Red"]: j = Empty[/COLOR]
Set Alan = Union(Range("F64"), Range("H64"), Range("J64"), Range("L64"))
For Each a In Alan
If Format(a.Value, "#,##0.00") <> 0 Then s = s & "," & a.Address
Next
If UBound(Split(s, ",")) > 0 Then
Fiyat_1 = Format(WorksheetFunction.Small(Range(Right(s, Len(s) - 1)), 1), "#,##0.00")
If UBound(Split(s, ",")) > 1 Then _
Fiyat_2 = Format(WorksheetFunction.Small(Range(Right(s, Len(s) - 1)), 2), "#,##0.00")
    For Each veri In Alan
        If veri.Value = CDbl(Fiyat_1) And n = Empty Then
        n = veri.Address
            Range("D68") = Cells(11, veri.Column - 1)
            Range("G68") = Cells(12, veri.Column - 1)
            Range("K68") = CDbl(Fiyat_1)
            Range("D70") = Cells(11, veri.Column - 1)
            Range("G70") = Cells(12, veri.Column - 1)
            Range("K70") = CDbl(Fiyat_1)
        End If
        If Fiyat_2 <> "" Then
        If veri.Value = CDbl(Fiyat_2) And n <> veri.Address Then
      [COLOR="Red"] If j = Empty Then
       j = 1[/COLOR]
            Range("D69") = Cells(11, veri.Column - 1)
            Range("G69") = Cells(12, veri.Column - 1)
            Range("K69") = CDbl(Fiyat_2)
       [COLOR="Red"]End If:[/COLOR] End If: End If
    Next
If Fiyat_2 = "" Then MsgBox "Avantajlı 1 Adet bulundu", vbCritical
    End If
Set Alan = Nothing
End Sub
 
Son düzenleme:
SAYIN PİLNT
Rica etsem müsait bir zamanınızda
Kod: 
Dim Bak As Integer
    On Error Resume Next
    For Bak = 14 To 63
        
        Range("F" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("E" & Bak))
        Range("H" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("G" & Bak))
      Range("K" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("I" & Bak))
      Range("L" & Bak).Value = WorksheetFunction.SumProduct( _
                                        Range("D" & Bak), _
                                        Range("K" & Bak))
kodunu sizin kod ile birleştirme yapabilir misiniz?
 
Sayın Plint
foruma yükleme imkanınız var ise yükleyebilir misiniz?
 
plint ben yanlış yapmışım hallettim ellerine sağlık.
Verdiğim zahmetten dolayı hakkını helal et.
Herşey için teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst