Aynı rakamın eksi ve artı olduğu farklı iki satırı silmek

[okcomputer]

Merhaba, ekteki excel dosyasının G kolonunda aynı rakamın bir pozitif bir de negatif olan iki satırı mevcuttur. bu iki satırı silmek istiyorum. yardımcı olabilir misiniz.

https://sheet.zoho.com/view.do?url=http://link.to/spreadsheet.xls&name=newName

Çok teşekkürler, iyi çalışmalar

 

[Erdem Akdemir]

Merhaba,

Ek yok.

 

[okcomputer]

ek nasıl ekleyebiliyorum bulamadım. dosya ekle yok.

 

[Orion1]

Dosyanıza upload sitelerinden birinden link alıp buraya verebilirsiniz.
Altın üye olmayanlara dosya ekleme özelliği yok.

 

[okcomputer]

linki kaydettim, teşekkürler..

 

[Orion1]

Linkiniz çalışmıyor.
Aşağıdaki linkten upload etmeyi deneyiniz.
DOSYA YÜKLE

 

[okcomputer]

https://docs.google.com/spreadsheets/d/1RiKY5_OyHkU_Qynvdv3xvY9YLer2YI5UaeGQdDHzihg/edit?usp=sharing

webscence izin vermiyor. yukarıdaki linke kaydettim, uğraştırdım sizi, kusura bakmayın.

 

[Orion1]

Oturum aç diyor.
6 nolu mesajdan verdiğim linkten yollayın.

 

[okcomputer]

yükledim..

 

[Orion1]

yükledim..

Hani nerde?

 

[okcomputer]

pardon bu linkte: http://www.dosya.tc/server2/npw15x/Book3.xlsx.html

 

[veyselemre]

Sub artiEksiKarsilastirSil()
    bas = Timer

    Application.ScreenUpdating = False
    ActiveSheet.Copy after:=Sheets(1)

    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")

    g = Application.Transpose(Range("g1:g" & Cells(Rows.Count, "a").End(3).Row).Value)
    For i = 2 To UBound(g)
        al = g(i)
        If al > 0 Then
            If Not dic1.exists(al) Then
                ReDim w(1 To 1)
                w(1) = i
                dic1.Add al, w
            Else
                w = dic1(al)
                ReDim Preserve w(1 To UBound(w) + 1)
                w(UBound(w)) = i
                dic1.Item(al) = w
            End If
        ElseIf al < 0 Then
            al = Abs(al)
            If Not dic2.exists(al) Then
                ReDim w(1 To 1)
                w(1) = i
                dic2.Add al, w
            Else
                w = dic2(al)
                ReDim Preserve w(1 To UBound(w) + 1)
                w(UBound(w)) = i
                dic2.Item(al) = w
            End If
        End If
    Next i

    it1 = dic1.keys

    For i = 0 To UBound(it1)
        al1 = dic1.Item(it1(i))
        If dic2.exists(it1(i)) Then
            al2 = dic2.Item(it1(i))
            If UBound(al1) <= UBound(al2) Then ind = UBound(al1) Else ind = UBound(al2)
            For ii = 1 To ind
                Rows(al1(ii)).ClearContents
                Rows(al2(ii)).ClearContents
            Next ii
        End If
    Next i

    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
    Debug.Print Format(Timer - bas, "0.000")
    Set dic1 = Nothing: Set dic2 = Nothing
End Sub

 

[okcomputer]

çok teşekkür ederim. ancak excel sayfasını kitliyor. 20 dakikadır döndürüyor, bir sonuç bulamadı.

 

[veyselemre]

#12 nolu mesajdaki kod revize edildi.

 

[okcomputer]

çok teşekkür ederim. elinize sağlık. bir de aynı çalışmanın tersini yapabilir miyiz. yani aynı olan rakamlar (bir eksi, bir artı olan) excel' de kalsın, aynı olmayan rakamlar uçsun.

Tekrar teşekkürler, iyi çalışmalar

 

[veyselemre]

çok teşekkür ederim. elinize sağlık. bir de aynı çalışmanın tersini yapabilir miyiz. yani aynı olan rakamlar (bir eksi, bir artı olan) excel' de kalsın, aynı olmayan rakamlar uçsun.

Tekrar teşekkürler, iyi çalışmalar

Sub artiEksiEslerKalsin()
    bas = Timer

    Application.ScreenUpdating = False
    ActiveSheet.Copy after:=Sheets(1)

    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")

    g = Application.Transpose(Range("g1:g" & Cells(Rows.Count, "a").End(3).Row).Value)
    For i = 2 To UBound(g)
        al = g(i)
        If al > 0 Then
            If Not dic1.exists(al) Then
                ReDim w(1 To 1)
                w(1) = i
                dic1.Add al, w
            Else
                w = dic1(al)
                ReDim Preserve w(1 To UBound(w) + 1)
                w(UBound(w)) = i
                dic1.Item(al) = w
            End If
        ElseIf al < 0 Then
            al = Abs(al)
            If Not dic2.exists(al) Then
                ReDim w(1 To 1)
                w(1) = i
                dic2.Add al, w
            Else
                w = dic2(al)
                ReDim Preserve w(1 To UBound(w) + 1)
                w(UBound(w)) = i
                dic2.Item(al) = w
            End If
        End If
    Next i

    it1 = dic1.keys

    For i = 0 To UBound(it1)
        al1 = dic1.Item(it1(i))
        If dic2.exists(it1(i)) Then
            al2 = dic2.Item(it1(i))
            If UBound(al1) <= UBound(al2) Then ind = UBound(al1) Else ind = UBound(al2)
            For ii = 1 To ind
                Cells(al1(ii), "O") = "**"
                Cells(al2(ii), "O") = "**"
            Next ii
        End If
    Next i
    Cells(1, "O") = "**"
    Columns("O:O").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("O:O").ClearContents
    Application.ScreenUpdating = True
    Debug.Print Format(Timer - bas, "0.000")
    Set dic1 = Nothing: Set dic2 = Nothing
End Sub

 

[okcomputer]

elinize sağlık, çok teşekkür ederim. çok sağolun..

 

[okcomputer]

G kolonunda aynı rakamın bir pozitif bir de negatif olan iki satırı mevcut. bu iki satırı silmek istiyorum. bir eksi bir artı olan rakamlar uçsun. bunun dışındakiler dursun, mümkün mü?

tekrar teşekkürler