• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Cinsine Göre Ayırıp Toplamını Almak

  • Konbuyu başlatan Konbuyu başlatan ormann
  • Başlangıç tarihi Başlangıç tarihi
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
İyi akşamlar ;
Ekteki örnek dosyada C5 sutunundaki verileri H sutununda cinsine göre ayırıp , I2 hücresine ise bölme numarasını yazdığım zaman d,e,f sutunundaki verilerin toplamını cinsine göre ve bölme numarasına göre toplamlarını ı,j,k sutunlarındaki ilgili alanlara aldırmak mümkün müdür?.
Not:Ekteki dosyada örneği mevcuttur.
 

Ekli dosyalar

Son düzenleme:
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub toplacins59()
Dim sat As Long, i As Long, n As Long, liste(), myarr()
Dim deg As String, z As Object
If Range("I2").Value = "" Then
    MsgBox "BÖLME NO girilmemiş,işlem iptal oldu!", vbCritical, "U Y A R I"
    Range("I2").Select
    Exit Sub
End If
Range("H5:K" & Rows.Count).ClearContents
Application.ScreenUpdating = False
sat = Cells(Rows.Count, "B").End(xlUp).Row
liste = Range("B5:F" & sat).Value
ReDim myarr(1 To 4, 1 To UBound(liste))
Set z = CreateObject("scripting.dictionary")
For i = 1 To UBound(liste)
    deg = liste(i, 2)
    If liste(i, 1) = Range("I2").Value Then
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = liste(i, 2)
        End If
        myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + liste(i, 3)
        myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 4)
        myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 5)
    End If
Next i
Erase liste
ReDim Preserve myarr(1 To 4, 1 To n)
If z.Count > 0 Then
    Range("H5").Resize(z.Count, 4) = Application.Transpose(myarr)
End If
Erase myarr
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName

    
End Sub
 

Ekli dosyalar

Sayın hocam I hücresine bölmeyi yazdığım zaman yine tüm bölmelerdeki verileri getiriyor.Benim istediğim sadece hangi bölme girilirse o bölmedeki cinsi ve o cinslerin toplamını alacak.
 
ormann' Alıntı:
Sayın hocam I hücresine bölmeyi yazdığım zaman yine tüm bölmelerdeki verileri getiriyor.Benim istediğim sadece hangi bölme girilirse o bölmedeki cinsi ve o cinslerin toplamını alacak.
Genişletmek için tıkla ...

Dosyayı güncelledim.
2 nolu mesajdan indirebilirsiniz.:cool:
 
Sayın hocam hızır gibi yetişiyorsunuz.Çok teşekkür ederim.Dosyayı asıl dosyama uyarlamak istiyorum.Fakat formüller çok karışık geldi bana.Rica etsem asıl dosyayı göndersem ve eklemeler yapsam ona göre uyarlama yaparmısınız?
 
ormann' Alıntı:
Sayın hocam hızır gibi yetişiyorsunuz.Çok teşekkür ederim.Dosyayı asıl dosyama uyarlamak istiyorum.Fakat formüller çok karışık geldi bana.Rica etsem asıl dosyayı göndersem ve eklemeler yapsam ona göre uyarlama yaparmısınız?
Genişletmek için tıkla ...
Resmi şeyler var ise,yada sakıncalı ise email adresime yollayabilirisiniz.
evrengizlen@hotmail.com
 
Sayın hocam ;İstihkak sayfasındaki sarı renkli sutunlardaki veriler özet sayfasında e3 hücresine bölme numarasını girdiğimiz zaman sarı renkli hücrelere cinsine göre toplamını, aldırabilirmiyiz?.Ayrıca bölme numarasını boş bırakırsak özet sayfasına tüm bölmelerin toplamını aldırabilirmiyiz.
Eğer mümkünse bu işlemi butonla değilde hücreye veriyi girdiğimizde otamatik olarak yaptırabilirmiyiz.?Birde özet sayfasında kaç adet cins varsa c sütününa sıra numarası verdirebilirmiyiz?
 

Ekli dosyalar

ormann' Alıntı:
Sayın hocam ;İstihkak sayfasındaki sarı renkli sutunlardaki veriler özet sayfasında e3 hücresine bölme numarasını girdiğimiz zaman sarı renkli hücrelere cinsine göre toplamını, aldırabilirmiyiz?.Ayrıca bölme numarasını boş bırakırsak özet sayfasına tüm bölmelerin toplamını aldırabilirmiyiz.
Eğer mümkünse bu işlemi butonla değilde hücreye veriyi girdiğimizde otamatik olarak yaptırabilirmiyiz.?Birde özet sayfasında kaç adet cins varsa c sütününa sıra numarası verdirebilirmiyiz?
Genişletmek için tıkla ...
Hangi sayfadaki veriyi girince otomatik hesaplama yapsın.:cool:
 
Siz daha önceki örnekte butonla yapmıştınız ya. Bu dosyada aynı işlemi butonla değilde özet sayfasında e3 hücresine bölme numarasını girdiğim zaman ve sildiğim zaman olabilitmi
 
ormann' Alıntı:
Siz daha önceki örnekte butonla yapmıştınız ya. Bu dosyada aynı işlemi butonla değilde özet sayfasında e3 hücresine bölme numarasını girdiğim zaman ve sildiğim zaman olabilitmi
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sat As Long, i As Long, n As Long, liste(), myarr()
Dim deg As String, z As Object, sh As Worksheet, blmNo
If Intersect(Target, [E3]) Is Nothing Then Exit Sub
Set sh = Sheets("İSTİHKAK")
Range("C7:J" & Rows.Count).ClearContents
Application.ScreenUpdating = False
sat = sh.Cells(Rows.Count, "G").End(xlUp).Row
liste = sh.Range("D7:M" & sat).Value
ReDim myarr(1 To 8, 1 To UBound(liste))
Set z = CreateObject("scripting.dictionary")
blmNo = Range("E3").Value
For i = 1 To UBound(liste)
    If Range("E3").Value = "" Then blmNo = liste(i, 1)
    If liste(i, 1) = blmNo Then
        deg = liste(i, 4)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = n
            myarr(2, n) = liste(i, 4)
        End If
        myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 5)
        myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 6)
        myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + liste(i, 7)
        myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + liste(i, 8)
        myarr(7, z.Item(deg)) = myarr(7, z.Item(deg)) + liste(i, 9)
        myarr(8, z.Item(deg)) = myarr(8, z.Item(deg)) + liste(i, 10)
    End If
Next i
Erase liste
If z.Count > 0 Then
    ReDim Preserve myarr(1 To 8, 1 To n)
    Range("C7").Resize(z.Count, 8) = Application.Transpose(myarr)
End If
Erase myarr
Set z = Nothing
Application.ScreenUpdating = True
If n > 0 Then
    MsgBox "[ " & Range("E3").Value & " ]  NO'LU BÖLME BULUNMUŞTUR." & vbLf & _
        "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
    Else
    MsgBox "BÖLME Bulunamadı!!", vbCritical, "U Y A R I"
End If

End Sub
 

Ekli dosyalar

Hocam bunda satır miktarı sınırlı mı?.Ayrıca özet sayfasında e3 hücresine olmayan bir bölmeyi girdiğimiz zaman bölme bulunamadı.Eğer var olan bölmeyi girersek 158 nolu bölme bulundu diye uyarı verilebilir mi?
 
ormann' Alıntı:
Hocam bunda satır miktarı sınırlı mı?.Ayrıca özet sayfasında e3 hücresine olmayan bir bölmeyi girdiğimiz zaman bölme bulunamadı.Eğer var olan bölmeyi girersek 158 nolu bölme bulundu diye uyarı verilebilir mi?
Genişletmek için tıkla ...
Dosyayı güncelledim.
12 nolu mesajdan indirebilirsiniz.:cool:
 
Sayın hocam gecenin bu vaktinde sizi zahmete soktuk.Hakkınızı helal edin.Allah sizden razı olsun.Sizin gibi değerli hocaları başamızdan eksik etmesin.Her şey için çok teşekkür ederim.
 
ormann' Alıntı:
Sayın hocam gecenin bu vaktinde sizi zahmete soktuk.Hakkınızı helal edin.Allah sizden razı olsun.Sizin gibi değerli hocaları başamızdan eksik etmesin.Her şey için çok teşekkür ederim.
Genişletmek için tıkla ...

Rica ederim.
İyi geceler.:cool:
 
Sayın Evren bey yapmış olduğunuz dosyaya sutun eklemesi yaptım fakat işin içinden çıkamadım.Rica etsem ekteki dosyaya bir bakarmısınız?
 

Ekli dosyalar

ormann' Alıntı:
Sayın Evren bey yapmış olduğunuz dosyaya sutun eklemesi yaptım fakat işin içinden çıkamadım.Rica etsem ekteki dosyaya bir bakarmısınız?
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sat As Long, i As Long, n As Long, liste(), myarr()
Dim deg As String, z As Object, sh As Worksheet, blmNo
If Intersect(Target, [E3]) Is Nothing Then Exit Sub
Set sh = Sheets("İSTİHKAK")
Range("C7:S" & Rows.Count).ClearContents
Application.ScreenUpdating = False
sat = sh.Cells(Rows.Count, "G").End(xlUp).Row
liste = sh.Range("D7:V" & sat).Value
ReDim myarr(1 To 17, 1 To UBound(liste))
Set z = CreateObject("scripting.dictionary")
blmNo = Range("E3").Value
For i = 1 To UBound(liste)
    If Range("E3").Value = "" Then blmNo = liste(i, 1)
    If liste(i, 1) = blmNo Then
        deg = liste(i, 4)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = n
            myarr(2, n) = liste(i, 4)
        End If
        myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 5)
        myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 6)
        myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + liste(i, 7)
        myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + liste(i, 8)
        myarr(7, z.Item(deg)) = myarr(7, z.Item(deg)) + liste(i, 9)
        myarr(8, z.Item(deg)) = myarr(8, z.Item(deg)) + liste(i, 10)
        myarr(9, z.Item(deg)) = myarr(9, z.Item(deg)) + liste(i, 11)
        myarr(10, z.Item(deg)) = myarr(10, z.Item(deg)) + liste(i, 12)
        myarr(11, z.Item(deg)) = myarr(11, z.Item(deg)) + liste(i, 13)
        myarr(12, z.Item(deg)) = myarr(12, z.Item(deg)) + liste(i, 14)
        myarr(13, z.Item(deg)) = myarr(13, z.Item(deg)) + liste(i, 15)
        myarr(14, z.Item(deg)) = myarr(14, z.Item(deg)) + liste(i, 16)
        myarr(15, z.Item(deg)) = myarr(15, z.Item(deg)) + liste(i, 17)
        myarr(16, z.Item(deg)) = myarr(16, z.Item(deg)) + liste(i, 18)
        myarr(17, z.Item(deg)) = myarr(17, z.Item(deg)) + liste(i, 19)
    End If
Next i
Erase liste
If z.Count > 0 Then
    ReDim Preserve myarr(1 To 17, 1 To n)
    Range("C7").Resize(z.Count, 17) = Application.Transpose(myarr)
End If
Erase myarr
Set z = Nothing
Application.ScreenUpdating = True
If n > 0 Then
    MsgBox "[ " & Range("E3").Value & " ]  NO'LU BÖLME BULUNMUŞTUR." & vbLf & _
        "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
    Else
    MsgBox "BÖLME Bulunamadı!!", vbCritical, "U Y A R I"
End If
End Sub
 

Ekli dosyalar

Evren bey günaydın.Dosya tam oldu derken problem çıktı.Özet sayfasından E2 hücresinden 159 nolu bölmeyi çağırdığım zaman hata vermiyor.Fakat 13 ve 45 nolu bölmeyi çağırdığım zaman hata alıyorum.sziden ricam ekteki dosyaya bir bakarmısınız ?
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst