mükerrer ve sıralama ?

[parsley2]

üzerinde çalıştığım bir programda takıldım.Ekteki örneğini sunduğum sorunu i makro ile gidermem gerekiyor. Yardım ederseniz memnun olurum.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin. Yalnız dosyanızdaki verilerde tuhaflık var. Örneğin 80 sayısını 1'e çevirdikten sonra sonradaki veriden dolayı 1 tekrar 82'ye çevriliyor.

Sub degistir()
For a = 2 To [a65536].End(3).Row
If WorksheetFunction.CountIf(Range("c2:c" & a), Cells(a, "c")) = 1 Then
[f:f].Replace What:=Cells(a, "c"), Replacement:=Cells(a, "a"), LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End If
Next
End Sub

 

[Ömer]

Merhaba,

Alternatif olsun..

Sub BulDeğis()
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Set c = Range("C:C").Find(Cells(i, "F"), , LookIn:=xlValues)
        If Not c Is Nothing Then
            Cells(i, "F") = Range("A" & c.Row)
        End If
    Next i
End Sub

.

 

[Orion1]

Dosyanzız ektedir.

Sub sira_59()
Dim no As Long, i As Long, sat As Long, j As Long, aralik As Long
Application.ScreenUpdating = False
Range("A2:C65536").Clear
sat = Cells(65536, "F").End(xlUp).Row
If sat < 2 Then GoTo son
j = 2
For i = 2 To sat
    If Cells(i, "F").Value <> "" Then
        Cells(j, "C").Value = Cells(i, "F").Value
        j = j + 1
    End If
Next
Range("C2:C" & j).Sort key1:=Range("C2"), order1:=xlDescending
sat = Cells(65536, "C").End(xlUp).Row
j = 2
For i = 2 To sat
    If WorksheetFunction.CountIf(Range("C2:C" & i), Cells(i, "C").Value) = 1 Then
        no = no + 1
        aralik = WorksheetFunction.CountIf(Range("C" & i & ":C" & sat), Cells(i, "C").Value)
        Range("A" & i & ":A" & i + aralik).Value = no
    End If
Next
son:
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı" & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[parsley2]

öncelikle cevaplarınızı bu kadar hızlı sürede verdiğiniz için ayrı ayrı teşekkürlerimi sunarım. bilseydim bu kadar hızlı geleceğini akşam beklerdim. =)))
şu an hepsini tek tek inceliyorum. Saygı ve sevgilerimi sunarım.

 

[Orion1]

öncelikle cevaplarınızı bu kadar hızlı sürede verdiğiniz için ayrı ayrı teşekkürlerimi sunarım. bilseydim bu kadar hızlı geleceğini akşam beklerdim. =)))
şu an hepsini tek tek inceliyorum. Saygı ve sevgilerimi sunarım.

Levent bey ve Ömer bey konuyu benden farklı anlamışlar.
Ben daha değişik anladım.Umarım olmuştur.
Kolay gelsin.

 

[parsley2]

yanıt

Evren bey, dediğiniz gibi siz daha farklı anlamışsınız. Levent bey ve Ömer beyin anladığı şekilde sormuştum. Ancak, vermiş olduğunuz kodlardan da faydalandım. tekrar teşekkürlerimi sunarım

 

[parsley2]

sorun2

saygı değer üstatlarım, çok sıkıştığım bir durumla daha karşı karşıyayım. örnek kodda bir mekkerrer durumla ilgili sıralama sorunum var. yardımcı olursanız çok memnun olacağım.

 

[Ömer]

Bu şekilde deneyiniz..

Sub SıraNoVer()
 
Dim i As Long, de As Long, fe As Long, sira As Long, son As Long
 
son = Cells(Rows.Count, "F").End(xlUp).Row
Application.ScreenUpdating = False
 
Range("B2:B" & son).ClearContents
For i = 2 To son
    If de <> Cells(i, "D") Then
        sira = 1
        de = Cells(i, "D")
        fe = Cells(i, "F")
    Else
        If fe <> Cells(i, "F") Then
            sira = sira + 1
            fe = Cells(i, "F")
        End If
    End If
    Cells(i, "B") = sira
Next i
 
Application.ScreenUpdating = True
End Sub

.

 

[parsley2]

çok çok teşekkürler Ömer bey, kardeşim tam istediğim gibi olmuş. Allah razı olsun.

 

[aydınlık]

Evren hocam size bir soru sormak istiyorum yardımcı olur musunuz