A Sütunundda tekrar eden verileri toplam ve aynı sayfada birleştirme

[hsayar]

Aşağıdaki gibi bir çalışma sayfamız olsun (veriler 8. satırdan başlar)

[FONT=Courier New]BAYRAMBEY   MAH.        1001   314   274   271   0   271   3       
BAYRAMBEY   MAH.        1002   314   279   276   0   276   3
BAYRAMBEY   MAH.        1003   314   282   276   0   276   6
BOZKURT MAH.            1004   301   256   252   0   252   4  
BOZKURT MAH.            1005   300   260   258   0   258   2
BOZKURT MAH.            1006   300   262   253   0   253   9
BOZKURT MAH.            1007   300   265   262   0   262   3
KAPUCU MAH.             1008   277   251   242   0   242   9
KAPUCU MAH.             1009   277   263   248   0   248   15
KAPUCU MAH.             1010   277   267   259   0   259   8
KAPUCU MAH.             1011   275   256   245   0   245   11
[/FONT]

A sütununda (Bayrambey vs...) tekrarlanan satırları b sütunununda verinin yer ladığı ilk satırnosundaki sandık no - verinin yer aldığı son satırnosundaki sandık no formatında birleşitirip, C-AM sütunlarındaki toplamlarını alaracak makro nasıl olmalıdır. Örnek çıktı aşağıdaki gibidir.

[FONT=Courier New]
BAYRAMBEY MAH      1001-1003    942     835     823    0     823    12
BOZKURT MAH.       1004-1007   1201    1043    1025    0    1025    18
KAPUCU MAH.        1008-1011   1106    1037     994    0     994    43
[/FONT]

 

[halit3]

örnek dosya eklermisiniz

 

[hsayar]

Örnek Dosya Eklidir.

 

[hsayar]

SNDSND(girdi) sayfasındaki veriler, mahbir(çıktı) sayfasındaki görünüme kavuşacak...
not SNDSND(girdi) sayfasında en altta yer alan "KÖPRÜ MAH." ni "KÖPRÜ MAH.(ce)" olarak düzelltiniz.

 

[kulomer46]

Aşağıdaki Makro kodu işinize yarar İnşallah..
Vakit bulursam dahada geliştirip gönderirim..

Sub AKTAR()
Dim i, son, son1
Dim satir, sutun, j, k
Dim c
Dim col As New Collection ' col değişkeni Collection nesnesi olarak tanımlanıyor..
Dim rg As Range
Dim hcr As Range


son = Cells(65500, 1).End(xlUp).Row
''MsgBox son

For i = 8 To son

'cells(

Next


Range(Cells(8, 1), Cells(son, 1)).Select
Selection.Copy


Cells(son + 3, 1).Select
ActiveSheet.Paste

'End


Set rg = Intersect(ActiveWindow.Selection, Cells(1, 1).Parent.UsedRange)
'seçili alan içinde excel tarafından kullanılan hücreler range
' olarak tanımlanmış rg nesnesine atılıyor

On Error Resume Next
For Each hcr In rg.Cells
If hcr <> "" Or hcr <> empyt Then

col.Add CStr(hcr), CStr(hcr) 'rg nesnesine atılan
'hücreler col adlı collection nesnesine atanıyor.
'Bu değişken türü aynı türde 2. bir değişkeni bünyesinde barındırmaz..
End If
Next

'Aşağıda benzersiz kayıtları seçili alanda soldan sağa yerleştiren kodlar var..

satir = rg.Rows.Count
sutun = rg.Columns.Count
rg.Clear

For i = 1 To satir
For j = 1 To sutun
k = k + 1
If k > col.Count Then
' MsgBox "Benzersiz " & col.Count & " adet kayıt var."
GoTo atla
End If
If col.Item(k) <> "" Or col.Item(k) = Empty Then rg.Cells(i, j) = col.Item(k)

Next
Next
' MsgBox "Hiç benzer kayıt bulunamadı."
atla:
son1 = Cells(65500, 1).End(xlUp).Row
'MsgBox son1
For i = son + 3 To son1
For j = 8 To son
If Cells(i, 1) = Cells(j, 1) Then
For m = 4 To 40
Cells(i, m) = Cells(i, m) + Cells(j, m)
Next
End If
Next
'' Cells(i, 3) = Cells(8, 3) & " - " & Cells(son, 3)
Next


'MsgBox son


End Sub

 

[N.Ziya Hiçdurmaz]

yanıt

Kodu SNDSND(girdi) sayfasında çalıştırınız.

Sub toplaaktar()
Dim sm As Worksheet
Dim sat, sats, satm, s As Integer
    Set sm = Sheets("MAHBIR(SONUC)")
    s = 8
        For sat = 8 To Cells(65536, "a").End(xlUp).Row
            If Not WorksheetFunction.CountIf(Range("a8:a" & sat), Cells(sat, "a")) > 1 Then
                Cells(sat, "a").Copy
                sm.Cells(s, "a").PasteSpecial
                s = s + 1
             End If
        Next
        sm.[b8:am500] = Empty
        For sats = 8 To Cells(65536, "a").End(xlUp).Row
        For satm = 8 To sm.Cells(65536, "a").End(xlUp).Row
            If Cells(sats, "a") Like sm.Cells(satm, "a") Then
                sm.Cells(satm, "b") = sm.Cells(satm, "b") & "-" & Cells(sats, "b")
                sm.Cells(satm, "c") = sm.Cells(satm, "c") + Cells(sats, "c")
                'diğer sütunları ilave ediniz
            End If
        Next: Next
Application.CutCopyMode = False
Set sm = Nothing
End Sub

 

[halit3]

alternatif olarak bir dosyada ben koydum dosya aşağıdaki mesajde

 

[hsayar]

san halit alakanıza teşekkür edereim, ufak bir keleme yapabilirseniz; AI, AJ sütunlarında bazen veri olabiliyor. bu nedenle sndaıktan>mahalli birime toplam alırken AM sütununa kadar standart yapsak boşsa sa aldırış etmesin değer 0 olsun önemli değil.

 

[halit3]

ekli dosyanizı kontrol ediniz sıfır değerleri silecektir

 

[hsayar]

sn halit emeğimniz için teşekkürler...
nur ziya hocam sizede teşekkür ederim zahmet etmişsiniz.