ACİLL YARDIM LÜTFEN..!!

Katılım
10 Ocak 2016
Mesajlar
36
Excel Vers. ve Dili
Office 2019
Arkadaşlar Merhaba,

Bir çalışmam üzerinde sizlerden desteklerinizi rica ediyorum.

Çalışmam içerisinde yer alan "B" kolonu bu işlevi gerçekleştirecek alandır. Bir araç düşünün ve aynı tarihte birden fazla yerde uğrama yaptığını beyan eden KM bilgileri yer almaktadır. Benim istediğim sizlerden şu kayıtlar eğer aynı ise "Gerçek KM" alanına bakarak en yüksek değerin karşısına en yüksek KM yazacak ("B Kolonuna") eğer gerçek km ("A") maksimum değerden küçükse "0 -(sıfır)" yazsın eğer aynı ise ilk aynı olduğu büyük değere eşit olduğu km yazıp ("B") diğer geride kalanların hepsine "0-(sıfır)" yazmasını rica ediyorum.



Bu içeriğe klasör yüklemeyi bilmediğim için. Çalışmayı Google Drive üzerinde ki linkten paylaşıyorum.

Link: https://drive.google.com/open?id=1mFVsfwdqTFQ7sXeKozQe57uTwauJrBSj
 

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
552
Excel Vers. ve Dili
Office365 TR
Linkteki dosyayı inceleyiniz. B2,G2,H2 hücrelerindeki formülleri kendi dosyanızda ki ayni hücrelere kopyalayın ve aşağıya doğru formülleri çoğaltınız.

 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,803
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Alternatif olsun.
Aşağıdaki kodu sayfa1 in kod kısmına kopyalayıp çalıştırın.

Kod:
Sub KM_Kontrol()
    Dim Bak As Long
    Dim SatirSay As Long
    Dim Bakx As Long
    Dim SatirSayx As Long
    Dim syfX As Worksheet
    Set syfX = YeniSayfa
    SatirSayx = syfX.Cells(Rows.Count, "A").End(xlUp).Row
    SatirSay = Cells(Rows.Count, "A").End(xlUp).Row
    Range("B2:B" & SatirSay) = 0
    For Bakx = 2 To SatirSayx
        For Bak = 2 To SatirSay
            If Cells(Bak, "E") = syfX.Cells(Bakx, "A") And Cells(Bak, "A") = Cells(Bak, "F") Then
                Cells(Bak, "B") = Cells(Bak, "F")
                Exit For
            End If
        Next
    Next
    Application.DisplayAlerts = False
    syfX.Delete
    Application.DisplayAlerts = True
    MsgBox "İşlem tamamlandı."
End Sub

Function YeniSayfa() As Worksheet
    Dim syf As Worksheet
    Dim syfX As Worksheet
    Set syf = ActiveSheet
    Set syfX = Sheets.Add(After:=ActiveSheet)
    syf.Activate
    syf.Columns("E:E").Copy syfX.Range("A1")
    Application.CutCopyMode = False
    syfX.Range("A1:A" & Rows.Count).RemoveDuplicates Columns:=1, Header:=xlYes
    Set YeniSayfa = syfX
End Function
 
Üst