Benzersizleri Çıkarma

[Orion1]

Baktım ama boşluk vs yok dosyayı paylaşamıyorum ama verdiğim rakamlarda bir veri olduğundan yola çıkarak tahmin edebilirsin diye düşünüyorum

Aşağıdaki kodu deneyiniz.

Sub benzersizler2()
Dim sat As Long, i As Long
sat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = sat To 2
    If WorksheetFunction.CountIf(Range("A" & i & ":A2"), Cells(i, "A").Value) > _
            1 Then Range("A" & i).EntireColumn.Delete (xlUp)
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[bytoprak]

Aşağıdaki kodu deneyiniz.

Sub benzersizler2()
Dim sat As Long, i As Long
sat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = sat To 2
    If WorksheetFunction.CountIf(Range("A" & i & ":A2"), Cells(i, "A").Value) > _
            1 Then Range("A" & i).EntireColumn.Delete (xlUp)
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

bir dosya halinde göndermeniz mümkün mü ekledim ama bir değişiklik olmadı..

 

[Orion1]

bir dosya halinde göndermeniz mümkün mü ekledim ama bir değişiklik olmadı..

Dosyanız ektedir.
Ayrıca bir açıklama yaptım dosyada.

Sub benzersizler2()
Dim sat As Long, i As Long
sat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = sat To 2 Step -1
    If WorksheetFunction.CountIf(Range("A" & i & ":A2"), Cells(i, "A").Value) > 1 Then
        Range("A" & i).EntireRow.Delete (xlUp)
    End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[bytoprak]

Dosyanız ektedir.
Ayrıca bir açıklama yaptım dosyada.

Sub benzersizler2()
Dim sat As Long, i As Long
sat = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = sat To 2 Step -1
    If WorksheetFunction.CountIf(Range("A" & i & ":A2"), Cells(i, "A").Value) > 1 Then
        Range("A" & i).EntireRow.Delete (xlUp)
    End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

açıklamayı anlayamadım

 

[Orion1]

açıklamayı anlayamadım

Yine olmadımı.
sanırım biz konuyu anlayamadık.
üstte ve altta sarı renge boyadığım veriler ayni veriler.
alttakiler silindi ve tek kaldı üstteki sarılar.Siz böylemi olmasınız istiyorsunuz?
O yüzden o açıklamayı yazdım.

 

[bytoprak]

Yine olmadımı.
sanırım biz konuyu anlayamadık.
üstte ve altta sarı renge boyadığım veriler ayni veriler.
alttakiler silindi ve tek kaldı üstteki sarılar.Siz böylemi olmasınız istiyorsunuz?
O yüzden o açıklamayı yazdım.

Galiba yine olmadı

 

[Orion1]

Galiba yine olmadı

Alttaki sarı alandaki hücreler silinip üstteki sarı hücreler kalıyor.Çünkü 1 er tane oluyorlar.
Sanırım siz bundan farklı bir şey istiyorsunuz.
Ben şimdi dosyayı size yolluyorum siz orada silinecek verileri kırmızıya boyayyın.
Ve dosyayı bana yollayın.

 

[50ersin]

Sub aktar()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("a") ' veri sayfası
Set s2 = Sheets("b") 'aktarılan sayfa

s2.Range("a1:c" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "k").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 2 To son1
ara1(j) = s1.Cells(j, "b") & s1.Cells(j, "d") & s1.Cells(j, "k")
ara2(j) = 1
Next j

sat1 = 1

For r = 1 To son1
aranan1 = ara1(r)

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
End If
Next i

s2.Cells(sat1, 1).Value = s1.Cells(r, 2).Value
s2.Cells(sat1, 2).Value = s1.Cells(r, 4).Value
s2.Cells(sat1, 3).Value = s1.Cells(r, 11).Value
sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub




s2.Cells(sat1, 3).Value = s1.Cells(r, 11).Value
Burada saat var sayı olarak geliyor burayı 01:00 nasıl yapabiliriz.