a sutunundaki isimleri veteğerlerini toplayarak tekrar a sutununa yazacak

[jambow]

a sutununda aynı isimlerin verilerini toplayarak tekrar a sutununa yazacak bir nevi bakım -listenin küçültülmesi dosya ekte

yardımcı olacak arkadaşlara şimdiden teşekkürler

 

[ozgretmen]

A ve B sütunlarında verileriniz var ama...

 

[jambow]

işte o verileri temizleyerek yerine toplanmış olan verileri yazacak


şöyle : şimdi oradaki makro a ve b sutunlarında aynı olan isimleri toplayarak yantarafa yazıyor benim istediğim yine aynı toplamayı yapacak a ve b yi komple silecek ve temizlenmiş olan bu sutunlara yapıştırılacak.

 

[ozgretmen]

Aşağıdaki kodları Module1 içine ekleyiniz.Ama A ve B sütunundaki veriler tamamen yok olacaktır.Böyle bir çözüm geldi aklıma.İyi çalışmalar.

Sub mukerrer()
Dim hcr As Range, sat As Long, sayi As Long
sat = 2
Sheets("Sayfa1").Select
Application.ScreenUpdating = False

Range("D2:G65536").ClearContents

For Each hcr In Range("A2:A" & Cells(65536, "A").End(xlUp).Row)
    If WorksheetFunction.CountIf(Range("A2:A" & hcr.Row), hcr.Value) = 1 Then
        sayi = WorksheetFunction.CountIf(Range("A2:A65536"), hcr.Value)
        
        Cells(sat, "d").Value = hcr.Value
        Cells(sat, "E").Value = sayi
        
        Cells(sat, "F").Value = WorksheetFunction.SumIf(Range("A2:A65536"), hcr.Value, Range("B2:B65536"))
        
        If sayi = 1 Then Cells(sat, "G").Value = sayi
        
        sat = sat + 1

    End If

Next
Application.ScreenUpdating = True
Call sadele
MsgBox "İşlem Tamamdır..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

Sub sadele()
Columns("A:C").Select
Selection.ClearContents
Columns("D:G").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Columns("E:G").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Application.CutCopyMode = False
End Sub

 

[Necdet]

Merhaba,

Bir çözümde benden olsun. Aşağıdaki kodları bir modüle bağlayabilirsiniz.

Sub Duzenle()
Dim i, Son As Long
Application.ScreenUpdating = False
Son = [A65536].End(3).Row
Range("A2:B" & Son).Sort Key1:=[A1]
For i = Son To 2 Step -1
    If Cells(i, "A") = Cells(i - 1, "A") Then
        Cells(i - 1, "B") = Cells(i - 1, "B") + Cells(i, "B")
        Rows(i).Delete
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub