Makro ile yüzde hesaplama

[umitumit]

Arkadaşlar merhaba.

2 sayfadan oluşan bir dosyam var.
Sayfa2 de LOT NO , WB GRUP, ADET ve KALİTELERİN (AAK, AAİ, ABK...) yazıldığı bir listem var.
Sayfa1 de B5 hücresine 1 yazdığım zaman, D9:O18 arasındaki tabloya LOT 1 in kalite yüzdelerinin gelmesi gerekiyor. Aynı şekilde B5 hücresine 2 yazdığım zamanda LOT 2 nin kalite yüzdelerinin gelmesi gerekiyor.
(LOT 1 ve LOT 2 için tabloya gelmesi gereken değerleri ekli dosyada yazdım)

Tabloyu TOPLA.ÇARPIM ile hazırladım ve çalışıyor ancak dosyayı çok yoruyor.

Makro ile her gruba tanımlama yapıp, her hücre için ayrı ayrı makro yazabilirim ama bu da 120 hücre için 120 Makro demek.

Çok daha pratik bir yöntem mutlaka vardır.

Yardımlarınızı rica ediyorum.

 

[systran]

örnek dosyayı inceleyiniz.
https://drive.google.com/folderview?id=0By_vlGkmFxCCflB0YU5ORlJlRWFhNG5qbkhRS0ZscVN0eGo2ZUVFeUF0a2I4eFlvN0ZpQWM&usp=sharing

-Sayfa1 de SArı kutuya sayıyı yazıp butona basın.
-Sayfa2 ye veri ekleme haricinde, sakın tablo yerini ve Q:AC sütunları aralığındaki alttoplam formüllerini bozmayınız.
-Sayfa1 deki bazı verilerin karşılığı sayfa2 de tam olarak aynı olmadığından boş geliyor kontrol ediniz.
-Örnek olarak Sayfa1 10*15 İNEK, Sayfa2 10*15 olarak yazıyor bunlara dikkat edin.
-hesaplamaları kontrol edin hata olmasın.

 

[Saban Sertkaya]

Alternatif,

Not : Lütfen yardım için özel mesaj atmayınız ve özel mesajda dosya linki vermeyiniz.

Link : http://dosya.web.tr/RV1lJK

 

[veyselemre]

ilk sayfanızdaki kriterlerinizi
35+
30-35
23-30
16-23
16-
kurban
24+
16-24
10*15
boyun

şeklinde sayfa2 deki verilere uygun olarak düzenleyin.

Sub yuzdeHesapla()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s2Son = s2.Cells(Rows.Count, "B").End(3).Row
    Dim w(1 To 13)
    With CreateObject("Scripting.Dictionary")
        For i = 3 To s2Son
            ref = Trim(s2.Cells(i, "B").Value) & "|" & Trim(s2.Cells(i, "C").Value)
            If Not .exists(ref) Then .Item(ref) = w
            y = .Item(ref)
            For ii = 1 To 13
                y(ii) = y(ii) + s2.Cells(i, ii + 3).Value
            Next ii
            .Item(ref) = y
        Next i
        s1.Select
        [d9:o18].ClearContents
        For i = 9 To 18
            ref = Trim([b5].Value) & "|" & Cells(i, "B").Value
            If .exists(ref) Then
                y = .Item(ref)
                For ii = 2 To 13
                    Cells(i, ii + 2).Value = y(ii) / y(1)
                Next ii
            End If
        Next i
    End With
    Set s1 = Nothing
    Set s2 = Nothing
End Sub

 

[umitumit]

Sayın saban20152015

Verdiğiniz cevabı kendi dosyama uyguladım.

Sub Makro2()
'On Error Resume Next
Sheets("RAPOR").Range("M27:X36").ClearContents
x = 13: y = 24
10
For a = 27 To 36
For b = 14 To [k755].End(xlUp).Row
If Sheets("RAPOR").Range("ı9") = Cells(b, 11) And Sheets("RAPOR").Cells(a, 5) = Cells(b, 12) Then
c = c + Cells(b, 14)
d = d + Cells(b, y)
End If
Next b
e = d / c
Sheets(RAPOR).Cells(a, x) = e
c = 0: d = 0: e = 0
Next a
x = x + 1: y = y + 1
If x = 25 Then
Sheets("RAPOR").Select
Exit Sub
Else
GoTo 10
End If

End Sub


Ancak e = d / c satırında hata veriyor.
Sabahtan beri uğraşıyorum ama düzeltemedim.

Düzenleme 1: 35+, 30-35, 23-30, 16-23 ve 16- nin AAK hesaplamalarını yapıyor ve tabloya yazıyor. "KURBAN" satır AAK sütunundan itibaren tüm hücreler boş ve "Run Time Error '6'" "Overflow" hatası veriyor.
Düzenleme 2: Buldum ve çözdüm. hatayı görmek için "On Error Resume Next" i devre dışı bırakmıştım.
0/0 yazılması gereken hücrelere hata verdiği için Makro duruyormuş. Devreye alınca sorunum çözüldü.

Sayın veyselemre,

Sizin çözümünüzü henüz denemedim.

Emekleriniz için teşekkürler.

 

[Saban Sertkaya]

Hucre adreslerinin önemli olduğunu söylemiştik. Kendi dosyanizda tablonun ve verinin olduğu yerleri birebir aynı olan bir ornek eklerseniz, uyarlama için bakarız.

 

[umitumit]

Buldum ve çözdüm. hatayı görmek için "On Error Resume Next" i devre dışı bırakmıştım.
0/0 yazılması gereken hücrelere hata verdiği için Makro duruyormuş. Devreye alınca sorunum çözüldü.

İlgi ve geri dönüşünüz için teşekkürler.

 

[umitumit]

Çözüldü

Buldum ve çözdüm. Hatayı görmek için "On Error Resume Next" i devre dışı bırakmıştım.
0/0 yazılması gereken hücrelere hata verdiği için Makro duruyormuş. Devreye alınca sorunum şimdilik çözüldü.
Ancak, Sayfa2 ye koyduğunuz Düğme yerine Sayfa 1 deki B5 hücresi değişince çalıştırmamız gerekiyor.

İlgi ve geri dönüşünüz için teşekkürler.

 

[Saban Sertkaya]

Rica ederim, kolay gelsin.

Sayın systran ve veyselemre' yi de unutmayınız.

 

[umitumit]

Teşekkürler ancak bir üst mesajda belirttiğim gibi küçük bir düzenleme daha yapmamız gerekiyor.

 

[Saban Sertkaya]

Kodu ilgili sayfanin selection change koduna yazarak deneyiniz. Yapamazsaniz musait olduğumda bakarız.

 

[Saban Sertkaya]

Kod düzenlemeyi biliyorsunuz. Ben hazırda olan kendi kodlarım üzerinde düzenlemeyi yapıyorum.
Siz de kendinize göre uyarlayınız. Kodlar Sayfa1'in kod bölümüne yazılmıştır.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("B5")) Is Nothing Then
Exit Sub
Else
On Error Resume Next
Range("D9:O18").ClearContents
x = 4: y = 5
10
For a = 9 To 18
For b = 3 To Sheets("Sayfa2").[C65536].End(xlUp).Row
If Range("B5") = Sheets("Sayfa2").Cells(b, 2) And Cells(a, 2) = Sheets("Sayfa2").Cells(b, 3) Then
c = c + Sheets("Sayfa2").Cells(b, 4)
d = d + Sheets("Sayfa2").Cells(b, y)
End If
Next b
e = d / c
Cells(a, x) = e
c = 0: d = 0: e = 0
Next a
x = x + 1: y = y + 1
If x = 16 Then
Exit Sub
Else
GoTo 10
End If
End If
End Sub

 

[umitumit]

Teşekkür ederim, düzenledim ve sorunsuz çalıştı.

 

[Saban Sertkaya]

Rica ederim, kolay gelsin.