mükerrer kayıt

[ahm11]

arkadaşlar ekteki örnekdeki bir makroya ihtiyacım var.

 

[Orion1]

Dosyanız ektedir.

Sub mukerrer()
Dim i As Long, sat As Long, sat2 As Long
Range("J1:M65536").Clear
sat = Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To sat
    If WorksheetFunction.CountIf(Range("A1:A" & i), Cells(i, "A").Value) = 1 Then
        sat2 = sat2 + 1
        Cells(sat2, "J").Value = Cells(i, "A").Value
        If WorksheetFunction.CountIf(Range("A1:A65536"), Cells(i, "A").Value) > 1 Then
            Cells(sat2, "M").Value = WorksheetFunction.SumIf(Range("A" & i & ":A" & sat), Cells(i, "A").Value, Range("B" & i & ":B" & sat))
            Else
            Cells(sat2, "K").Value = Cells(i, "B").Value
            Cells(sat2, "L").Value = Cells(i, "C").Value
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Veriler çıkarıldı." & vbLf & _
"evrengizlenqhotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[ahm11]

evren gizlen cevabın için teşekkürler.ancak kodu çalıştırdığımda mükerrer kayıtlar siliniyor onların silinmemesi gerekiyor.yani örnekteki J:M arasındaki görüntüyü almam lazım.

 

[Orion1]

evren gizlen cevabın için teşekkürler.ancak kodu çalıştırdığımda mükerrer kayıtlar siliniyor onların silinmemesi gerekiyor.yani örnekteki J:M arasındaki görüntüyü almam lazım.

Dosyanız ektedir.

Sub mukerrer()
Dim i As Long, sat As Long, sat2 As Long, k As Range, adr As String
Range("J1:M65536").Clear
sat = Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To sat
    If WorksheetFunction.CountIf(Range("A1:A" & i), Cells(i, "A").Value) = 1 Then
        sat2 = sat2 + 1
        If WorksheetFunction.CountIf(Range("A1:A65536"), Cells(i, "A").Value) > 1 Then
            Cells(sat2, "J").Value = Cells(i, "A").Value
            Cells(sat2, "M").Value = WorksheetFunction.SumIf(Range("A" & i & ":A" & sat), Cells(i, "A").Value, Range("B" & i & ":B" & sat))
            Cells(sat2, "J").Font.Color = vbRed
            Cells(sat2, "M").Font.Color = vbRed
            Set k = Range("A:A").Find(Cells(i, "A").Value, , xlValues, xlWhole)
            If Not k Is Nothing Then
                adr = k.Address
                Do
                    sat2 = sat2 + 1
                    Cells(sat2, "J").Value = Cells(k.Row, "A").Value
                    Cells(sat2, "K").Value = Cells(k.Row, "B").Value
                    Cells(sat2, "L").Value = Cells(k.Row, "C").Value
                    Set k = Range("A:A").FindNext(k)
                Loop While Not k Is Nothing And k.Address <> adr
            End If
            Else
            Cells(sat2, "J").Value = Cells(i, "A").Value
            Cells(sat2, "K").Value = Cells(i, "B").Value
            Cells(sat2, "L").Value = Cells(i, "C").Value
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Veriler çıkarıldı." & vbLf & _
"evrengizlenqhotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[ahm11]

sayın evren gizlen çok teşekkür ederim.

 

[Orion1]

sayın evren gizlen çok teşekkür ederim.

Rica ederim.
İyi çalışmalar.