Değerlerin Farkını Bulma

[gicimi]

Merhaba,

Ekteki örnek excel çalışması için yardımlarınızı rica ederim.

* Giriş tarihine göre malzeme numarası bulup Girilen Değeri sütundaki verileri çıkarıp farkını bulmak istiyorum. Bulunan farkı Sayfa2 ye Malzeme Numarası , Türü sütunlarını ve karşına farkı yazmasını istiyorum.

Kolay gelsin. Şimdiden yardımlarınızdan dolayı teşekkür ederim.

 

[Ömer]

Merhaba,

Konuyu tam olarak anlayamadım.
Bu şekilde deneyin.

Sub Fark_Bul()

    Dim d As Object, i As Long, s, deg, a1, a2

    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    
    Range("A2:E" & Rows.Count).Sort , Key1:=Range("A1"), _
        Key2:=Range("B1"), Key3:=Range("D1"), Order3:=xlAscending

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A") & "|" & Cells(i, "B")
        If Not d.exists(deg) Then
            s = Cells(i, "E")
            d.Add deg, s
        Else
            s = d.Item(deg)
            s = s - Cells(i, "E")
            d.Item(deg) = s
        End If
    Next i
  
    Sheets("Sayfa2").Select
    Range("A2:C" & Rows.Count).Clear
    
    a1 = d.keys: a2 = d.items
    For i = 0 To d.Count - 1
        Cells(i + 2, "A") = Split(a1(i), "|")(0)
        Cells(i + 2, "B") = Split(a1(i), "|")(1)
        Cells(i + 2, "C") = a2(i)
    Next i
    
    Range("A2:C" & i + 1).Borders.LineStyle = 1
        
    Application.ScreenUpdating = True

End Sub

.

 

[gicimi]

Ömer Bey Merhaba,

Öncelikle çok teşekkür ederim istediğim tam buydu ancak koşul olarak büyük tarihten küçük tarihteki değerleri çıkarmasını istiyorum.

Yardımlarınız için teşekkür ederim.

 

[Ziynettin]

Merhaba,

Alternatif;

Option Explicit
Sub Fark_deneme()
Dim a(), b(), d1 As Object, d2 As Object
Dim i As Long, Say As Long, deg
Dim S1 As Worksheet, S2 As Worksheet
Application.ScreenUpdating = False
Set S1 = Sheets("Sayfa1"):
Set S2 = Sheets("Sayfa2"):
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
a = S1.Range("A2:E" & S1.Cells(Rows.Count, 1).End(3).Row)

For i = 1 To UBound(a)
    deg = a(i, 1) & a(i, 2)
    If d1.exists(deg) Then
        If a(i, 4) > a(d1(deg), 4) Then d1(deg) = i
        If a(i, 4) < a(d2(deg), 4) Then d2(deg) = i
    Else
        d1(deg) = i: d2(deg) = i
    End If
Next i

ReDim b(1 To d1.Count, 1 To 3)
For i = 1 To d1.Count
    Say = Say + 1
    deg = a(i, 1) & a(i, 2)
    b(Say, 1) = a(d1(deg), 1)
    b(Say, 2) = a(d1(deg), 2)
    b(Say, 3) = a(d1(deg), 5) - a(d2(deg), 5)
Next i

S2.Range("A2:C" & Rows.Count).Clear
If Say > 0 Then S2.[a2].Resize(d1.Count, 3) = b
S2.Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[gicimi]

Ziynettin Bey emeğinize sağlık teşekkür ederim. İyi Çalışmalar.

 

[Ömer]

Ömer Bey Merhaba,

Öncelikle çok teşekkür ederim istediğim tam buydu ancak koşul olarak büyük tarihten küçük tarihteki değerleri çıkarmasını istiyorum.

Yardımlarınız için teşekkür ederim.

Kodlardaki;

Order3:=xlAscending

yerine aşağıdaki değişikliği yapmanız yeterli.

Order3:=xlDescending

.

 

[gicimi]

Kodlardaki;

Order3:=xlAscending

yerine aşağıdaki değişikliği yapmanız yeterli.

Order3:=xlDescending

.

Ömer Bey Merhaba,

Çok teşekkür ederim yardımlarınızdan dolayı iyi çalışmalar.