Excel de A sütunundaki mükerrer sayılara göre satır toplama

[halilbay2]

Merhabalar
3000 satırlık tümüyle rakam olan bir tablomuz var bu tabloda A sütunundaki mükerrer sayıların satırlarını R sütuna kadar toplayan tek satır haline getiren bir makroya ihtiyacım var.
Herkese teşekkür eder başarılar dileerim

 

[Korhan Ayhan]

Selamlar,

Örnek bir dosya eklermisiniz.

 

[halilbay2]

A sütunundaki ükerrer sayılı satırları topla

İlgileriniz için teşekkür ederim

 

[Korhan Ayhan]

Selamlar,

Mükerrer kayıtlar hep ard ardamı yoksa farklı satırlarda varmı?

 

[halilbay2]

A sütunundaki ükerrer sayılı satırları topla

Mükerrer satırlar çok farklı burada yazımı kolay olduğu için öyle yazdım daha açıklyıcı bir ek daha gönderdim ilginize çok teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Son bir soru daha sorayım. Listenizdeki sıralama önemlimi? Kayıtların yerleri değişse problem yaratırmı?

 

[halilbay2]

A sütunundaki ükerrer sayılı satırları topla

satırların yer değiştirmesi önemli değil ama 3. satırın değrleri başka satırın değerleriyle değişmesin.Yani komle satır olarak kaçıncı satırda olursa olsun önemi yok.
Teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub MÜKERRER_KAYITLARI_SİL()
    Application.ScreenUpdating = False
    [S2] = 1
    [S3] = 2
    [S2:S3].AutoFill Destination:=Range("S2:S" & [A65536].End(3).Row), Type:=xlFillDefault
    Range("A2:S" & [A65536].End(3).Row).Sort Key1:=Range("A2")
    For X = [A65536].End(3).Row To 2 Step -1
    If Cells(X, 1) = Cells(X - 1, 1) Then
    For Y = 2 To 18
    Cells(X - 1, Y) = Cells(X - 1, Y) + Cells(X, Y)
    Next
    Rows(X).EntireRow.Delete
    End If
    Next
    Range("A2:S" & [A65536].End(3).Row).Sort Key1:=Range("S2")
    Columns("S").ClearContents
    Application.ScreenUpdating = True
    MsgBox "MÜKERRER KAYITLARI SİLME İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[halilbay2]

A sütunundaki ükerrer sayılı satırları topla

Göndermiş olduğunuz kod hata verdi. Kod bankasından bir kod buldum ama bu kod tek sütunu topluyor bana 18 sütun lazım bende bu sütun genişletmesini bilmiyorum. Siz hangi kodu düzenlerseniz benim ihtiyacımı karşılayacak.
İlginiz için gerçekten çok teşekkür ederim.
Saygılarımla

Dim isim, deger As Variant
Dim rng As Range
Dim i, z As Integer
i = 2
z = 1
Do
If Cells(i, 1).Value = "" Then GoTo bitti
If Range([A1], [A10000]).Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Row < i Then GoTo devam2
ReDim isim(z)
ReDim deger(z)
isim(z) = Cells.Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Value
deger(z) = Cells(i, 1).Offset(0, 1).Value
hcr = i
Do
On Error Resume Next
Set rng = Range(Cells(hcr, 1), [A10000]).FindNext
If rng.Row = hcr Then GoTo devam
hcr = rng.Row
deger(z) = deger(z) + rng.Offset(0, 1).Value
Loop
devam:
Sheets(2).Cells(z, 1).Value = isim(z)
Sheets(2).Cells(z, 2).Value = deger(z)
z = z + 1
devam2:
i = i + 1
Loop
bitti:
End Sub

 

[Korhan Ayhan]

Selamlar,

Örnek olarak eklediğiniz dosyalarda deneyerek göndermiştim kodu. Hangi satırda hata verdi acaba belirtirmisiniz. Yada dosyanızın orjinalinden küçük bir örnek ekleyin onun üzerinden gidelim.

 

[halilbay2]

A sütunundaki ükerrer sayılı satırları topla

Arkadaşım çok özür dilerim ben yan tarafta hücre birleştirmiştim size bilgi yazmak için, o hücreyi silince proplemsiz çalıştı.
Ellerinize sağlık Bu saatlere kadar benimle ilgilendiğiniz için ayrıca teşekkür edrim.
Saygılarımla hayatınızda başarılar dilerim.