ETOPLA Makro Hali

  • Konuyu başlatan Konuyu başlatan __TR__
  • Başlangıç tarihi Başlangıç tarihi
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

__TR__

Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
Sub Ayn?_H?creleri_Birle?tir()
Dim Rky As Integer, Ert As Integer, a As Integer

Application.DisplayAlerts = False
On Error Resume Next
For Rky = Range("A65536").End(3).Row To 1 Step -1
If Cells(Rky, "A").MergeCells = True Then
Ert = Rky
Exit For
End If
Next Rky
For a = Range("A65536").End(3).Row To Ert Step -1
If Cells(a, "A") = Cells(a - 1, "A") Then
Range(Cells(a, "I"), Cells(a - 1, "I")).Merge
End If
Next a
Application.DisplayAlerts = True
Rky = Empty: Ert = Empty: a = Empty
End Sub

Bu makro ile "A" sütunundaki aynı kayıtların olduğu satırları "I" sütununda birleştiriyorum. Yardım istediğim kısım;

Yine "A" sütununda aynı olan kayıtların "H" sütununda rakamsal değerlini "I" sütununu birleştirdikten sonra toplama. Umarım anlatabilmişimdir.

Eklediğim dosya örnek olarak hazırlanmıştır. Makro istenilen hale gelince asıl dosyaya entegre edilecektir.
 
Tek Şarta Göre Veri Alma
Hücrelerdeki Değerlerden Veri Oluşturma

Ekli dosyalar

Tarihe göre sırala Oylamaya göre sırala
Aşağıdaki kodu, sayfadaki düğme ile ilişkilendirip, düğmeye tıklayın..
VBA: 
Sub BIRLESTIR_TOPLA()
XD = Cells(Rows.Count, 1).End(3).Row
Range("I1:I" & XD).UnMerge: Range("I1:I" & XD).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 1 To XD
    ilk = WorksheetFunction.Match(Cells(sat, 1), [A:A], 0)
    son = ilk + WorksheetFunction.CountIf([A:A], Cells(sat, 1)) - 1
    Cells(ilk, 9) = WorksheetFunction.Sum(Range("H" & ilk & ":H" & son))
    Range("I" & ilk & ":I" & son).Merge: sat = son
Next: [I:I].VerticalAlignment = xlCenter: [I:I].HorizontalAlignment = xlGeneral
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı..", vbInformation, "Ömer BARAN"
End Sub
 
Oyla 0 Olumsuz oyla
Sub D??me1_T?kla()
XD = Cells(Rows.Count, 1).End(3).Row
Range("AO9:AO" & XD).UnMerge: Range("AO9:AO" & XD).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 9 To XD
ilk = WorksheetFunction.Match(Cells(sat, 1), [C:D], 0)
son = ilk + WorksheetFunction.CountIf([C:D], Cells(sat, 1)) - 1
Cells(ilk, 39) = WorksheetFunction.Sum(Range("AN" & ilk & ":AN" & son))
Range("AO" & ilk & ":AO" & son).Merge: sat = son
Next: [AO:AO].VerticalAlignment = xlCenter: [AO:AO].HorizontalAlignment = xlGeneral
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "??lem tamamland?..", vbInformation, "?mer BARAN"
End Sub

Ömer hocam asıl dosyaya uyarlamaya çalıştım ama sonuç vermiyor, hatam nerden kaynaklanıyor ?
 
Oyla 0 Olumsuz oyla
Mesaj yazarken vereceğiniz kod/formül metinlerini,
mesaj yazma alanının hemen üstündeki alanda bulunan •••▼ (üç nokta/aşağı ok) düğmesine tıklayıp, ilgili yere yapıştırınız.

Herneyse kullandığınız kodu aşağıdaki şekilde düzenlerseniz sonuç alınabilir.
C: 
Sub Düğme1_Tıkla()
XD = Cells(Rows.Count, "C").End(3).Row
Range("AO9:AO" & XD).UnMerge: Range("AO9:AO" & XD).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 9 To XD
    ilk = WorksheetFunction.Match(Cells(sat, "C"), [C:C], 0)
    son = ilk + WorksheetFunction.CountIf([C:C], Cells(sat, "C")) - 1
    Cells(ilk, "AO") = WorksheetFunction.Sum(Range("AN" & ilk & ":AN" & son))
    Range("AO" & ilk & ":AO" & son).Merge: sat = son
Next: [AO:AO].VerticalAlignment = xlCenter: [AO:AO].HorizontalAlignment = xlGeneral
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı..", vbInformation, "Ömer BARAN"
End Sub
 
Oyla 0 Olumsuz oyla
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Benzer Konular Popüler İçerikler Daha Fazlası
Geri
Üst