Yenilenen değerleri çıkarma ve yazdırma

[Belleksizz]

Merhaba
exte gönderdiğim excelde a ve b sutununda deger tutar alanları mevcut
bu alanlarda a stunun da 149186 degeri 2 defa mevcut kırmızı alan olarak belirledim b sutununda 149186 bu 2 degerin yanında 2 farklı tutar mevcut 149186 bu degerin yanındaki 2 tutarın birbirince - işlemi olarak çıkartıp kalan degeri 149186 bu degerin yanına yazdırmak istiyorum ve listede tek bir kayıt kalmasını istiyorum bu şekilde yapılacak yaklaşık 30bin satır var o yüzden bu konuda desteginizi talep ediyorum

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
Dim s As Object
Dim deg As String
Dim tut As Double
Dim a As Long
Set s = CreateObject("Scripting.Dictionary")
For a = 2 To Cells(Rows.Count, 1).End(3).Row
    deg = Cells(a, 1).Value
    tut = Cells(a, 2).Value
    If s.Exists(deg) Then
        s(deg) = Abs(s(deg) - tut)
    Else
        s.Add deg, tut
    End If
Next
Range("D2").Resize(s.Count).Value = Application.Transpose(s.keys)
Range("E2").Resize(s.Count).Value = Application.Transpose(s.items)
End Sub

 

[Belleksizz]

Ömer bey çok teşekkürler işe yaradı
yarın tüm dosyalara uygulayacağım
saygılar

 

[Belleksizz]

Merhaba,
Deneyiniz...

Sub kod()
Dim s As Object
Dim deg As String
Dim tut As Double
Dim a As Long
Set s = CreateObject("Scripting.Dictionary")
For a = 2 To Cells(Rows.Count, 1).End(3).Row
    deg = Cells(a, 1).Value
    tut = Cells(a, 2).Value
    If s.Exists(deg) Then
        s(deg) = Abs(s(deg) - tut)
    Else
        s.Add deg, tut
    End If
Next
Range("D2").Resize(s.Count).Value = Application.Transpose(s.keys)
Range("E2").Resize(s.Count).Value = Application.Transpose(s.items)
End Sub

Ömer bey merhaba


yaptığınız işe yaradı ama benim söylemeyi unuttuğum 1-2 kriter daha varmış çok pardon

sizden rica etsem ekte gönderdigim dosyayı yeniden incelermisiniz dosya içerisine notlar aldım nasıl bir işlem istediğimi

 

[ÖmerBey]

Buyurunuz...

Sub kod()
s = Cells(Rows.Count, 1).End(3).Row
dz = Range("A1:G" & s)
For a = LBound(dz) To UBound(dz) - 1
    For b = a + 1 To UBound(dz)
        If dz(a, 1) = dz(b, 1) And Mid(dz(a, 1), 2) = Mid(dz(b, 1), 2) Then
            dz(a, 3) = Abs(dz(a, 3) - dz(b, 3))
            For c = LBound(dz, 2) To UBound(dz, 2)
                dz(b, c) = ""
            Next
            Exit For
        End If
    Next
Next
With Range("J1").Resize(UBound(dz), UBound(dz, 2))
    .Value = dz
    .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
End Sub

 

[Belleksizz]

Buyurunuz...

Sub kod()
s = Cells(Rows.Count, 1).End(3).Row
dz = Range("A1:G" & s)
For a = LBound(dz) To UBound(dz) - 1
    For b = a + 1 To UBound(dz)
        If dz(a, 1) = dz(b, 1) And Mid(dz(a, 1), 2) = Mid(dz(b, 1), 2) Then
            dz(a, 3) = Abs(dz(a, 3) - dz(b, 3))
            For c = LBound(dz, 2) To UBound(dz, 2)
                dz(b, c) = ""
            Next
            Exit For
        End If
    Next
Next
With Range("J1").Resize(UBound(dz), UBound(dz, 2))
    .Value = dz
    .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
End Sub

Ömer bey tekrardan merhaba

Sizi çok fazla yordum kusura bakmayın inanın hakkınızı ödeyemem allah razı olsun

Ekte gönderdigim excele son verdiginiz kodu uygulamaya çalıştım kod çalıştı 4 5 dakika sürdü bitmesi ama sonuç vermedi

akabinde tekrar denedim bu defa da debug hatası oluştu

rica etsem son kez kontrol edip yardımcı olurmusunuz

Saygılar

Debugg.xlsx dosyasını indir - download

Debugg.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

dosya uzun oldugu için yüklemeyedim o yüzden link bırakıyorum

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Ozet_Analiz()
    Dim S1 As Worksheet, Dizi As Object, Veri As Variant, Son As Long
    Dim X As Long, Say As Long, Aranan As String, Y As Byte, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = S1.Range("A1:G" & Son).Value2
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 7)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 1) & "|" & Replace(Replace(Veri(X, 2), "İ", ""), "S", "")
        If Not Dizi.Exists(Aranan) Then
            Say = Say + 1
            Dizi.Add Aranan, Say
            For Y = 1 To 7
                Liste(Say, Y) = Veri(X, Y)
            Next
        Else
            If Liste(Dizi.Item(Aranan), 3) > Veri(X, 3) Then
                Liste(Dizi.Item(Aranan), 3) = Liste(Dizi.Item(Aranan), 3) - Veri(X, 3)
            Else
                Liste(Dizi.Item(Aranan), 3) = Veri(X, 3) - Liste(Dizi.Item(Aranan), 3)
                Liste(Dizi.Item(Aranan), 7) = Veri(X, 7)
            End If
        End If
    Next
    
    With Range("J1")
        .Offset(, 4).Resize(Say).NumberFormat = "@"
        .Resize(Say, 7) = Liste
        .Resize(Say, 7).Columns.AutoFit
    End With
    
    Set S1 = Nothing
    Set Dizi = Nothing
        
    MsgBox "Analiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Belleksizz]

Korhan bey işe yaradı
çok teşekkürler