Aynı kod satırlarının adetlerını, tek satıra toplama

[AirJ@rdan]

A sutunundaki aynı kodlar ıcın aynı kod satırlarını sılıcek,bu koddan bır tane kalıcak ve B sutundaki değerlerinin toplamlarınıda yan hücresine yazıcak bir macro koduna ihtiyacım var

 

[excel03]

merhaba;

'Bir başka kodun düzenlenmiş halidir.
Sub AralıkBelirle()
Dim vin As Range
Dim ParçaNo As Range
sonsat = Worksheets(1).Cells(65536, "A").End(3).Row
Set vin = Range("a2:a" & sonsat)
vin1 = [a2].Value 'Worksheets(1).Range("g4").Value
vin2 = Range("a" & sonsat).Value  'Worksheets(1).Range("g5").Value
x1 = "$a$2"
x2 = Range("a" & sonsat).Address
Range("J1:K" & sonsat - 1).ClearContents
Set ParçaNo = Range(x1 & ":" & x2)
Range(Range(x1).Offset(0, 1), Range(x2).Offset(0, 1)).Font.Bold = False
For j = 1 To ParçaNo.Cells.Count
        For t = 1 To ParçaNo.Cells.Count
        y = ParçaNo.Cells(j).Offset(0, 0).Value
        x = ParçaNo.Cells(t).Offset(0, 0).Value
        
        If x = y And ParçaNo.Cells(t).Offset(, 1).Font.Bold = False Then
        say = say + ParçaNo.Cells(t).Offset(, 1).Value
        ParçaNo.Cells(t).Offset(, 1).Font.Bold = True
        End If
        Next t
        sonsatO = Worksheets(1).Cells(65536, "j").End(3).Address
If say > 0 Then Range(sonsatO).Offset(1, 0).Value = y
If say > 0 Then Range(sonsatO).Offset(1, 1) = say
say = 0
Next j
Range(Range(x1).Offset(0, 1), Range(x2).Offset(0, 1)).Font.Bold = False
MsgBox "İşlem tamamlandı."
End Sub

 

[excel03]

sunucu yükleme hatasından dolayı çift mesaj ulaştığı için, mesaj iptal edildi.

 

[leumruk]

A sutunundaki aynı kodlar ıcın aynı kod satırlarını sılıcek,bu koddan bır tane kalıcak ve B sutundaki değerlerinin toplamlarınıda yan hücresine yazıcak bir macro koduna ihtiyacım var

Merhaba,
Alternatif olarak aşağıdaki örneği kullanabilirsiniz.

Sub Sadelestir()
Range("j2:j" & [j65536].End(3).Row + 1).ClearContents
For x = 2 To [a65536].End(3).Row
Say = WorksheetFunction.CountIf(Range("j2:j" & [j65536].End(3).Row + 1), Cells(x, "a"))
If Say = 0 Then
tpl = 0
Set Aralik = Range("a2:a" & [a65536].End(3).Row)
Set Bul = Aralik.Find(Cells(x, "a"), LookIn:=xlValues, lookat:=xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
            If IsNumeric(Cells(Bul.Row, "b")) Then
            tpl = tpl + CDbl(Cells(Bul.Row, "b"))
            End If
            Set Bul = Aralik.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
Sat = [j65536].End(3).Row + 1
Cells(Sat, "j") = Cells(x, "a")
Cells(Sat, "k") = tpl
End If
Next
End Sub

 

[AirJ@rdan]

Merhaba,
Alternatif olarak aşağıdaki örneği kullanabilirsiniz.

Sub Sadelestir()
For x = 2 To [a65536].End(3).Row
Say = WorksheetFunction.CountIf(Range("j2:j" & [j65536].End(3).Row + 1), Cells(x, "a"))
If Say = 0 Then
tpl = 0
Set Aralik = Range("a2:a" & [a65536].End(3).Row)
Set Bul = Aralik.Find(Cells(x, "a"), LookIn:=xlValues, lookat:=xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
            tpl = tpl + Val(Cells(Bul.Row, "b"))
            Set Bul = Aralik.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
Sat = [j65536].End(3).Row + 1
Cells(Sat, "j") = Cells(x, "a")
Cells(Sat, "k") = tpl
End If
Next
End Sub

Burda tamsayılarda problem olmuyorda toplarken, adetler virgüllü olursa virgül sonrasını toplarken hesaba katmıyor sadece tamsayı taraflarını topluyor.Toplarken virgüllü tarafıda hesaba katmamız mumkunmudur?

 

[leumruk]

Burda tamsayılarda problem olmuyorda toplarken, adetler virgüllü olursa virgül sonrasını toplarken hesaba katmıyor sadece tamsayı taraflarını topluyor.Toplarken virgüllü tarafıda hesaba katmamız mumkunmudur?

Merhaba,
Kodu ve dosyayı güncelledim.

 

[AirJ@rdan]

tesekkur ettim