Aynısı olanın önceki silinsin.

[mozdem]

Ekte bulunan dosyamda G sütununda x ve y harfleri var. Sıralanış şeklinin x,y,x,y yada y,x,y,x gibi olmasını istiyorum. burada ard arda gelmiş olan harf var ise silinme şartı önceki harf olmalı. örnek: G3, G8, G15, G21 de "X" harfi olsun G25 de "y" harfi olsun G3 G8 ve G15 deki "X" harfleri silinmesi G25 kalmalı. y harfi içinde x harfi görünene kadar y harfleri silinsin ama x harfinden önceki y harfi kalsın.

Yukarıda anlattığım konuda yardımcı olursanız asıl yapmak istediğimi yapacağımı zannediyorum. Asıl yapmak istediğim;
x harfi yerinde sıfırdan küçük değerler var. y harfi yerinde sıfırdan büyük değerler var. benim gerçek sıralamam +.-.+.- gibi olmuş olacak

Saatlerce uğraştım yapamadım.
Teşekkür ederim.
Dosyayı güncelledim

 

[alicimri]

Anladığım kadarı ile,
x ve y için

Sub birles1()
For i = Cells(Rows.Count, 7).End(3).Row To 1 Step -1
If Cells(i, 7) = Cells(i + 1, 7) Then
Rows(i + 1).Delete
End If
Next
End Sub

- ve + için

Sub birles2()
For i = Cells(Rows.Count, 7).End(3).Row To 1 Step -1
If (Cells(i, 7) > 0 And Cells(i + 1, 7) > 0) Or (Cells(i, 7) < 0 And Cells(i + 1, 7) < 0) Then
Rows(i + 1).Delete
End If
Next
End Sub

 

[mozdem]

Anladığım kadarı ile,
x ve y için

Sub birles1()
For i = Cells(Rows.Count, 7).End(3).Row To 1 Step -1
If Cells(i, 7) = Cells(i + 1, 7) Then
Rows(i + 1).Delete
End If
Next
End Sub

- ve + için

Sub birles2()
For i = Cells(Rows.Count, 7).End(3).Row To 1 Step -1
If (Cells(i, 7) > 0 And Cells(i + 1, 7) > 0) Or (Cells(i, 7) < 0 And Cells(i + 1, 7) < 0) Then
Rows(i + 1).Delete
End If
Next
End Sub

Yazmış olduğunuz kod satır siliyor. satır silmesi değil hücre içeriğini temizlemesi gerekiyor. Ancak bunu tam olarak belirtmemişim.

 

[Greenblacksea53]

Alicimri'nin yaptığı kodu aşağidaki kodla değiştir

Rows(i + 1).ClearContents

 

[mozdem]

Bu kod ile satırı temizliyor. ben G25 yada G33 gibi hücre içeriğini temzilemesini istiyordum. Ayrıca kodu çalıştırdığımda da X,y,x,y gibi sonuç dönmüyor
Ayrıca yazılan kod silmeye en alttaki satırdan başlıyor. Benim için en üst satırdan silmeye başlaması yani G3, G8, G15, G21 de "X" hargi varsa ve G25 de Y olsun, G3, G8, G15 deki x' lerin bulunduğu hücrelerin temizlenmesini istiyorum. Halan uğraşıyorum. Sizlerede teşekkür ederim.

 

[alicimri]

Deneyin

Sub birles1()
son = Cells(Rows.Count, 7).End(3).Row
For i = son To 1 Step -1
If Cells(i, 7) <> Cells(i + 1, 7) Then
bb = "," & Cells(i, 7) & bb
Else
bb = "," & "" & bb
End If
Next
bb = Split(Mid(bb, 2), ",")
Range("G1:G" & son).Clear
For e = 0 To UBound(bb)
Cells(e + 1, 7).Value = bb(e)
Next
End Sub

 

[Ziynettin]

Alternatif

Sub test()
a = Range("G1:G" & Cells(Rows.Count, "g").End(3).Row).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 1)
n = 1
For i = 1 To UBound(a)
    If a(i, 1) <> Empty Then
        say = say + 1
        b(say, 1) = a(i, 1)
        If say = 1 Then
            p = n
        Else
            If b(say, 1) <> b(say - 1, 1) Then
                n = n + 1
                p = n
            End If
        End If
        krt = b(say, 1) & p
        dc(krt) = dc(krt) & " | " & i
    End If
Next i

x = dc.items
For i = 0 To dc.Count - 1
    v = Split(x(i), " | ")
    If UBound(v) > 1 Then
        For j = 1 To UBound(v) - 1
        k = k & ",  " & v(j)
        Cells(v(j), 7).ClearContents
        Next j
     Else
    End If
Next i
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[mozdem]

Alternatif

Sub test()
a = Range("G1:G" & Cells(Rows.Count, "g").End(3).Row).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 1)
n = 1
For i = 1 To UBound(a)
    If a(i, 1) <> Empty Then
        say = say + 1
        b(say, 1) = a(i, 1)
        If say = 1 Then
            p = n
        Else
            If b(say, 1) <> b(say - 1, 1) Then
                n = n + 1
                p = n
            End If
        End If
        krt = b(say, 1) & p
        dc(krt) = dc(krt) & " | " & i
    End If
Next i

x = dc.items
For i = 0 To dc.Count - 1
    v = Split(x(i), " | ")
    If UBound(v) > 1 Then
        For j = 1 To UBound(v) - 1
        k = k & ",  " & v(j)
        Cells(v(j), 7).ClearContents
        Next j
     Else
    End If
Next i
MsgBox "İşlem bitti.", vbInformation
End Sub

Saatlerce uğraştım. yapamadım. Çok Teşekkür ederim. Tam istediğim gibi. Emeğinize sağlık. Sizin buradan diğer cevap yazan arkadaşlarada emekleri için teşekkür ediyorum.

 

[mozdem]

Yukarıdaki kod satırından

a = Range("G1:G" & Cells(Rows.Count, "g").End(3).Row).Value

a = Range("G4:G" & Cells(Rows.Count, "g").End(3).Row).Value

değiştirdiğimde kod çalışmıyor. 2 ve 3. satırda Başlıklar veya Tarih var. Onun için 4. satırdan nasıl başlatabilirim

 

[Erkan Akayay]

n = 1 kod satırı var. 4.satırdan başlayacaksınız n=4 yapın.

 

[mozdem]

Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 1)
n = 4
For i = 1 To UBound(a)
    If a(i, 1) <> Empty Then
        Say = Say + 1
        b(Say, 1) = a(i, 1)

dediğinizi yaptım ama yine kod istenileni vermedi

 

[Ziynettin]

Yeni ekli dosyanıza göre kod güncel tekrar deneyin.

Sub test()
a = Range("G4:G" & Cells(Rows.Count, "g").End(3).Row).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 2)
n = 1
For i = 1 To UBound(a)
    If a(i, 1) <> Empty Then
        say = say + 1
        b(say, 1) = (a(i, 1))
        If IsNumeric(b(say, 1)) = True Then
        If b(say, 1) > 0 Then b(say, 1) = "x"
        If b(say, 1) < 0 Then b(say, 1) = "y"
        End If
        If say = 1 Then
            p = n
            b(say, 2) = p
        Else
            If b(say, 1) <> b(say - 1, 1) Then
                n = n + 1
                p = n
                b(say, 2) = p
            End If
        End If
        krt = b(say, 1) & p
        dc(krt) = dc(krt) & " | " & i
    End If
Next i

x = dc.items
For i = 0 To dc.Count - 1
    v = Split(x(i), " | ")
    If UBound(v) > 1 Then
        For j = 1 To UBound(v) - 1
            Cells(v(j) + 3, 7).ClearContents
        Next j
     Else
    End If
Next i
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[mozdem]

Yeni ekli dosyanıza göre kod güncel tekrar deneyin.

Sub test()
a = Range("G4:G" & Cells(Rows.Count, "g").End(3).Row).Value
Set dc = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 2)
n = 1
For i = 1 To UBound(a)
    If a(i, 1) <> Empty Then
        say = say + 1
        b(say, 1) = (a(i, 1))
        If IsNumeric(b(say, 1)) = True Then
        If b(say, 1) > 0 Then b(say, 1) = "x"
        If b(say, 1) < 0 Then b(say, 1) = "y"
        End If
        If say = 1 Then
            p = n
            b(say, 2) = p
        Else
            If b(say, 1) <> b(say - 1, 1) Then
                n = n + 1
                p = n
                b(say, 2) = p
            End If
        End If
        krt = b(say, 1) & p
        dc(krt) = dc(krt) & " | " & i
    End If
Next i

x = dc.items
For i = 0 To dc.Count - 1
    v = Split(x(i), " | ")
    If UBound(v) > 1 Then
        For j = 1 To UBound(v) - 1
            Cells(v(j) + 3, 7).ClearContents
        Next j
     Else
    End If
Next i
MsgBox "İşlem bitti.", vbInformation
End Sub

Çok Teşekkür ederim. VBA kod hakkında az bir şey biliyorum ama bu yazdığınız koddan bir şey anlamıyorum. Sanırım
burada bana yabancı olan konu
Set dc = CreateObject("scripting.dictionary")
buna çalışacağım.
Tekrar teşekkür ederim.

 

[Erkan Akayay]

Merhaba ben n değerini xy sayfasında değiştirdiğimde çalışmıştı. artıeksi sayfasında çalışmıyormuş.
Artı eksi sayfası için size klasik çözümü alternatif olarak vereyim.
Tevfik Bey'in dictionary ve array çözümü gerçekten güzel. VBA'da ADO ve bunlar favorilerim.
Kodda son satır bulma gibi bir kaç ufak detay var ama onları halledersiniz.

Sub ArtiEksi()
pointer = 6

For satir = 7 To 45
başla:
    If Sgn(Range("G" & satir)) = Sgn(Range("G" & pointer)) Then
        Range("G" & pointer).Clear
        pointer = satir
    End If

    If Sgn(Range("G" & satir)) = 0 Then
        satir = satir + 1
        GoTo başla
    End If
    pointer = satir
Next
End Sub

 

[mozdem]

Yaptığınız kod çok güzel çalışıyor. Teşekkür ederim. Emeğinize sağlık. Yukarıda yazdıklarınıza aynen katılıyorum. Bir ara Excel VBA ile çok çalışıyordum. ADO ile de çalıştım şuan o işlemler seneler önce bitti bende bir çok konuları unutmuşum. Eski yaptıklarıma (Tabiki bu sitede bir çok kişilerin yardımı ile.) bakınca vay be diyorum. Çok şey unuttuğumu görüyorum.

Merhaba ben n değerini xy sayfasında değiştirdiğimde çalışmıştı. artıeksi sayfasında çalışmıyormuş.
Artı eksi sayfası için size klasik çözümü alternatif olarak vereyim.
Tevfik Bey'in dictionary ve array çözümü gerçekten güzel. VBA'da ADO ve bunlar favorilerim.
Kodda son satır bulma gibi bir kaç ufak detay var ama onları halledersiniz.

Sub ArtiEksi()
pointer = 6

For satir = 7 To 45
başla:
    If Sgn(Range("G" & satir)) = Sgn(Range("G" & pointer)) Then
        Range("G" & pointer).Clear
        pointer = satir
    End If

    If Sgn(Range("G" & satir)) = 0 Then
        satir = satir + 1
        GoTo başla
    End If
    pointer = satir
Next
End Sub