aynı isimleri altalta yazıp toplam alma?

[udentr2002]

Merhaba arkdaşlar;

Ekli dosyada da anlattım. Sayfada F stünunda bulunan aynı verileri alt alta gelecek şekilde yazıp altına bir satır boş bırakacak ve bu boş bıraktığı satırın H stünuna "TOPLAM" yazıp I stünunda ki değerlerin alt toplamını alıp yazacak.

Yani kısacası sayfada bulunan aynı verileri (F stünuna göre) altalta gelecek şekilde sıralayıp altınada alt toplamını alıp Sarf adlı sayfaya kopyalayacak.

Böyle bir örnek var ama çok karışık olduğu için hiç anlayamadım. Eğer isterseniz o örnekle ilgili kodu gönderebilrim.
O örneği kendi dosyama uyarlamaya çalıştığımda yanlış sonuçları gösteriyor

 

[udentr2002]

Örnek kod şu şekilde
/[On Error Resume Next
Dim shGR As Worksheet
Dim shGN As Worksheet
Dim i%, j%, sonilk%, son%, sonson%
Dim dg As Variant
Dim adres As String
Dim col As New Collection
Dim bul As Range
Set shGR = Sheets("Rapor")
Set shGN = Sheets("Sarf")
shGN.Cells.ClearContents


For i = 3 To shGR.Cells(65536, 2).End(xlUp).Row
col.Add shGR.Cells(i, 2), shGR.Cells(i, 2)
Next
On Error GoTo 0
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col.Item(i) > col.Item(j) Then
dg = col.Item(i)
col.Item(i) = col.Item(j)
col.Item(j) = dg
End If
Next j
Next i
shGN.Cells.ClearContents
shGN.Range("A2:L2").Value = shGR.Range("A2:L2").Value
For i = 1 To col.Count
Set bul = shGR.Columns(2).Find(col.Item(i), Lookat:=xlWhole)
If Not bul Is Nothing Then
adres = bul.Address
sonilk = shGN.Cells(65536, 7).End(xlUp).Row + 1

Do
son = shGN.Cells(65536, 7).End(xlUp).Row + 1
For j = 1 To 12
shGN.Cells(son, j) = shGR.Cells(bul.Row, j)
Next j
Set bul = shGR.Columns(2).FindNext(bul)
Loop While Not bul Is Nothing And adres <> bul.Address

sonson = son
shGN.Cells(son + 1, 8) = "TOPLAM"
shGN.Cells(son + 1, 9).Formula = "=SUM(" & shGN.Cells(sonilk, 9).Address & ":" & shGN.Cells(sonson, 9).Address & ")"
'shGN.Cells(son + 1, 7).Formula = "=SUM(" & shGN.Cells(sonilk, 7).Address & ":" & shGN.Cells(sonson, 7).Address & ")"
'shGN.Cells(son + 1, 8).Formula = "=SUM(" & shGN.Cells(sonilk, 8).Address & ":" & shGN.Cells(sonson, 8).Address & ")"
shGN.Cells(son + 2, 7) = " "
End If
Next i
shGN.Select
Set shGN = Nothing
Set shGR = Nothing
/]
belki yardımı dokunur diye yine burdaki üstatlardan birinin yapmış olduğu bir kod
bu kod çalışıyor fakat uyguladığınızda göreceksinizki bazı değerleri yanlış aktarıyor

 

[mustafaine1]

ekli dosyada bisey anlatilmamis; sarf numaralarini tek tek yazip hangisinin ne kadar toplami var bunumu bulmak istiyorsunuz?

 

[udentr2002]

F stünunda Raf Yeri adlı stünda yazan A-1'leri alt alta gelecek şekilde yazacak ve hemen onun altında bir boş satır bırakıp H stünuna TOPLAM yazacak ve Sarf yazan stündaki değerlerin altoplamını alıp yazacak Bunu A-2'ler içinde ve diğerleri içide alt alta yapacak her birinin arasına bir satır boş bırakacak

Not: Eğer gönderdiğim kodu kopyalayıp yapıştırıp denerseniz ne yapılması gerektiğini daha iyi anlarsınız sanırım.

Şimdiden emeğiniz için teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Sub aktar_topla()
Dim s1 As Worksheet, sat1 As Long, sat2 As Long, i As Long, k As Range, adr As String
Dim toplam As Double
Sheets("Rapor").Select
Application.ScreenUpdating = False
Range("A3:L65536").ClearContents
Set s1 = Sheets("Stok_Takip")
sat1 = s1.Cells(65536, "F").End(xlUp).Row
sat2 = 3
For i = 3 To sat1
    If WorksheetFunction.CountIf(s1.Range("F3:F" & i), s1.Cells(i, "F").Value) = 1 Then
        Set k = s1.Range("F3:F" & sat1).Find(s1.Cells(i, "F").Value, , xlValues, xlWhole)
        toplam = 0
        If Not k Is Nothing Then
            adr = k.Address
            Do
                Range("A" & sat2 & ":L" & sat2).Value = s1.Range("A" & k.Row & ":L" & k.Row).Value
                sat2 = sat2 + 1
                toplam = toplam + s1.Cells(k.Row, "I").Value
                Set k = s1.Range("F3:F" & sat1).FindNext(k)
            Loop While Not k Is Nothing And k.Address <> adr
            Cells(sat2, "H").Value = "TOPLAM"
            Cells(sat2, "I").Value = toplam
            sat2 = sat2 + 2
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[udentr2002]

Evren Hocam emeğine sağlık.
Yalnız şöyle bir şey var o işlemleri Sarf Sayfasına kopyalayıp yapacak tam kodlar dediğiniz gibi ama sadece Rapor sayfasında yapmayacak Sarf Sayfasında yapacak Bunun için tekrar yardımlarınızı rica edeceğim.

Not : Aynı olayları F stünuna göre değilde B stünundaki ad'a göre yapmayı düşünseydik eğer o zaman kodlarınızda F yazan yerleri B diye düzeltmemeiz yeterli olurmuydu yoksa başka değişikliklerde gerekirmi. Başka bir sayfada da B stünuna göre filtreleme yapmak sorunda kalacağım için sordum hocam.

Tekrardan ellerinize ve emeğinize sağlık

 

[Orion1]

Evren Hocam emeğine sağlık.
Yalnız şöyle bir şey var o işlemleri Sarf Sayfasına kopyalayıp yapacak tam kodlar dediğiniz gibi ama sadece Rapor sayfasında yapmayacak Sarf Sayfasında yapacak Bunun için tekrar yardımlarınızı rica edeceğim.

Not : Aynı olayları F stünuna göre değilde B stünundaki ad'a göre yapmayı düşünseydik eğer o zaman kodlarınızda F yazan yerleri B diye düzeltmemeiz yeterli olurmuydu yoksa başka değişikliklerde gerekirmi. Başka bir sayfada da B stünuna göre filtreleme yapmak sorunda kalacağım için sordum hocam.

Tekrardan ellerinize ve emeğinize sağlık

Kodlarda aşağıdaki satırdaki kırmızı yeri istediğiniz sayfayı yazın.
Diğer soru için f yazan yerleri B yapın.

[B]Sheets("[B][COLOR="Red"][SIZE="3"]Rapor[/SIZE][/COLOR][/B]").Select[/B]

 

[udentr2002]

Hocam çok ama çok teşekkür ederim emeğinize ve elelrinize tekrar sağlık

 

[Orion1]

Hocam çok ama çok teşekkür ederim emeğinize ve elelrinize tekrar sağlık

Rica ederim.

 

[udentr2002]

Evren Hocam;

Yapmaya çalıştıklarımı kademe kedeme gitmeya çalıştığım için şöyle bi sorum daha olacak.

Aynı mantıkla sayfada B stünundakileri alt alta yazdırıp H stünundaki değerlerin toplamını almak için ne yapabilrim. Ben sizin gönderdiğiniz kodu şu şekilde değiştirdim. ama "Run Time error 13 Type mismatch" hatası alıyorum

[/Dim s1 As Worksheet, sat1 As Long, sat2 As Long, i As Long, k As Range, adr As String
Dim toplam As Double
Sheets("Etkin-1").Select
Application.ScreenUpdating = False
Range("A3:L65536").ClearContents
Set s1 = Sheets("Etkin")
sat1 = s1.Cells(65536, "B").End(xlUp).Row
sat2 = 3
For i = 3 To sat1
If WorksheetFunction.CountIf(s1.Range("B3:B" & i), s1.Cells(i, "B").Value) = 1 Then
Set k = s1.Range("B3:B" & sat1).Find(s1.Cells(i, "B").Value, , xlValues, xlWhole)
toplam = 0
If Not k Is Nothing Then
adr = k.Address
Do
Range("A" & sat2 & ":H" & sat2).Value = s1.Range("A" & k.Row & ":H" & k.Row).Value
sat2 = sat2 + 1
toplam = toplam + s1.Cells(k.Row, "h").Value
Set k = s1.Range("B3:B" & sat1).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
Cells(sat2, "G").Value = "TOPLAM"
Cells(sat2, "H").Value = toplam
sat2 = sat2 + 2
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & "Evren Gizlen", vbOKOnly + vbInformation, "E V R E N"
/]

 

[koboy]

merhaba c sütünü MENŞEİ tekrar nasıl alabirim
h sütünüda toplam yazıyor gibi c de mesai tekrar yazmasını istiyorum