scripting.dictionary

[şehiriçi]

Merhaba arkadaşlar ,
Arkadaşlar dünden beri çözemediğim bir sıkıntıyı sizlerden destek bekliyorum.Ekteki dosyamın satko sayfasından C sütunundaki plakaları scripting.dictionary nesnesine her plakadan sadece 1 tane olacak şekilde yükleyip (araclar değişkenine) daha sonrada her plaka için başlangiç ve bitiş arasındaki farkı km sayfasına yazdırmak istiyorum.(satko sayfasında renklendirdim örnek j239-j113 ile 42 gbc 02 ye ait km farkını buluyoruz aynı şekilde diğer plakalarıda böyle sıralatmak istiyorum teşekkürler)

 

[RBozkurt]

Merhaba,
3 makro var. Aşağıdaki kod bloğunu modüle ekleyiniz.

PlakaBilgileriniAl makrosunu çalıştırmanız yeterlidir.

veya,

Private Sub CommandButton1_Click()
    Call PlakaBilgileriniAl
End Sub

Sub PlakaBilgileriniAl()
'RBozkurt 29.04.2023
    Dim satkoSayfa As Worksheet
    Dim kmSayfa As Worksheet
    Dim plaka As Range
    Dim sonPlaka As Range
    
    Set satkoSayfa = ThisWorkbook.Sheets("satko")
    Set kmSayfa = ThisWorkbook.Sheets("km")
    
    Set plaka = satkoSayfa.Range("C6")
    Set sonPlaka = satkoSayfa.Range("C" & Rows.Count).End(xlUp)
    
    With ThisWorkbook.Sheets("km")
        .Columns("A:D").ClearContents
        .Range("A2").Value = "Plaka"
        .Range("B2").Value = "İlk Km"
        .Range("C2").Value = "Son Km"
        .Range("D2").Value = "Fark"
    End With
    
    Do While plaka <> ""
        kmSayfa.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = plaka.Value
        Set plaka = plaka.Offset(1, 0)
    Loop

    kmSayfa.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    
    Call IlkKMAl
    Call SonKMAl
    
End Sub

Sub IlkKMAl()
    Dim satko As Worksheet, km As Worksheet
    Dim plaka As String, satkoPlaka As Range
    
    Set satko = ThisWorkbook.Worksheets("satko")
    Set km = ThisWorkbook.Worksheets("km")
    
    For i = 3 To km.Range("A" & km.Rows.Count).End(xlUp).Row
        plaka = km.Range("A" & i).Value
        Set satkoPlaka = satko.Range("C6:C" & satko.Range("C" & satko.Rows.Count).End(xlUp).Row).Find(plaka, LookIn:=xlValues)
        
        If Not satkoPlaka Is Nothing Then
            km.Range("B" & i).Value = satkoPlaka.Offset(0, 7).Value
        End If
    Next i
End Sub

Sub SonKMAl()
    Dim km As Worksheet
    Dim satko As Worksheet
    Dim plakalar As Range
    Dim plaka As Range
    Dim sonHuc As Range
    Dim sonSatir As Long
    Dim i As Long
    
    Set km = Worksheets("km")
    Set satko = Worksheets("satko")
    Set plakalar = km.Range("A3", km.Range("A3").End(xlDown))
    
    For Each plaka In plakalar
        sonSatir = satko.Cells(Rows.Count, "C").End(xlUp).Row
        For i = sonSatir To 6 Step -1
            If satko.Cells(i, "C").Value = plaka.Value Then
                Set sonHuc = satko.Cells(i, "J")
                If Not IsEmpty(sonHuc.Value) Then
                    km.Cells(plaka.Row, "C").Value = sonHuc.Value
                    km.Cells(plaka.Row, "D").Value = km.Cells(plaka.Row, "C").Value - km.Cells(plaka.Row, "B").Value
                    Exit For
                End If
            End If
        Next i
    Next plaka
End Sub

 

[şehiriçi]

Merhaba ,
Sn RBozkurt Eline Emeğine sağlık ,sonuca ulaşılıyor verilen kodlarla, ve bunu gerçek dosyamda kullanıcağım sağolun.
Yalnız bir şeyi söylemeden geçemiyeceğim .Ben isterdim ki scipting.dictionary nesnesi ile plakaları benzersiz bir şekilde bulup ona göre devam etmeyi , özellikle ben çalışmamda scipting.dictionary nesnesinin örneğin if Not Araclar.exists(.... diye başlayıp Araclar nesneswine plakaları atamadım bir türlü ,eğer scipting.dictionary ile de bir cevap alabilirsem benim gerçek dosyamda başka konulara da yardımcı olacaktır . Dosyanın son halini sizin koda göre revize edip ekliyorum ,teşekkürler