İki koşula uyanların toplamlarını alma

Ergün Güler · 10 Ağustos 2010

Selam,
Ekteki örnek dosyamdaki "Miktarlar" Sayfasındaki Fonksiyonlar ile yaptığım iki koşlu göre toplama işlemini Makro ile yapmak istiyorum.
Yardımcı olabilirseniz Çok sevinirim.
İyi çalışmalar.

Korhan Ayhan · 10 Ağustos 2010

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub HESAPLA()
    Dim Satır As Integer, Sütun As Byte
    
    Application.ScreenUpdating = False
    
    For Satır = 3 To 16
        If Satır <> 15 And Satır <> 16 Then
            For Sütun = 2 To 8
                If Sütun <> 7 And Sütun <> 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((MONTH(itarih))=" & Cells(Satır, 1) & ")*(ioperatör=""" & Cells(2, Sütun) & """)*(imiktar))")
                ElseIf Sütun = 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((MONTH(itarih))=" & Cells(Satır, 1) & ")*(imiktar))")
                End If
            Next
        
        ElseIf Satır = 16 Then
            For Sütun = 2 To 8
                If Sütun <> 7 And Sütun <> 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((YEAR(itarih))=" & Cells(Satır, 1) & ")*(ioperatör=""" & Cells(2, Sütun) & """)*(imiktar))")
                ElseIf Sütun = 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((YEAR(itarih))=" & Cells(Satır, 1) & ")*(imiktar))")
                End If
            Next
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Ergün Güler · 14 Ağustos 2010

Selam Sayın Korhan Ayhan,
Çok güzel olmuş ellerinize sağlık. Bir kaç sorum olacak;
1-) kodlarınızın içinde benim tanımladığım adlar var adlar tanımlı olmasaydı ne yapmamız gerekirdi?
2-) Kodlarınızdaki

Evaluate("=SUMPRODUCT(((MONTH(itarih)).....

v.s. gibi excel fonksiyonları olmasa idi başka türlü nasıl yapılabilirdi.
3-) sizden istifade ile farklı yöntem olarak döngüler ile aşağıdaki kodları oluşturdum. Çalışıyor Ancak sizin kodlardan yavaş çalışıyor.

Kod:

Private Sub CommandButton1_Click()
Dim Satır As Integer, Sütun As Byte
Dim s1, s2 As Worksheet

Set s1 = Sheets("insört")
Set s2 = Sheets("Miktarlar")

Application.ScreenUpdating = False

s2.Range("B3:H16").ClearContents
son = s1.Cells(65536, 1).End(3).Row
    For Satır = 3 To 16
        If Satır <> 15 And Satır <> 16 Then
            For Sütun = 2 To 8
                If Sütun <> 7 And Sütun <> 8 Then
                    For i = 3 To son
                        If s1.Cells(i, 4) = s2.Cells(2, Sütun) And Month(s1.Cells(i, 3)) = s2.Cells(Satır, 1) Then
                        s2.Cells(Satır, Sütun) = s2.Cells(Satır, Sütun) + s1.Cells(i, 12)
                        End If
                    Next
                ElseIf Sütun = 8 Then
                    For i = 3 To son
                        If Month(s1.Cells(i, 3)) = s2.Cells(Satır, 1) Then
                        s2.Cells(Satır, Sütun) = s2.Cells(Satır, Sütun) + s1.Cells(i, 12)
                        End If
                    Next
                    
                End If
            Next
        
        ElseIf Satır = 16 Then
            For Sütun = 2 To 8
                If Sütun <> 7 And Sütun <> 8 Then
                     For i = 3 To son
                        If s1.Cells(i, 4) = s2.Cells(2, Sütun) Then
                        s2.Cells(Satır, Sütun) = s2.Cells(Satır, Sütun) + s1.Cells(i, 12)
                        End If
                    Next
                ElseIf Sütun = 8 Then
                     For i = 3 To son
                        
                        s2.Cells(Satır, Sütun) = s2.Cells(Satır, Sütun) + s1.Cells(i, 12)
                        
                    Next
                                    
                                                      
                End If
            Next
        End If
    Next

s2.Range("B3:H16").NumberFormat = "#,## ""Adet"""
  
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

i döngüsünü sadeleştirebilir miyiz?

s2.Cells(Satır, Sütun) = s2.Cells(Satır, Sütun) + s1.Cells(i, 12)

kısmını

toplam=toplam + s1.Cells(i, 12)
s2.Cells(Satır, Sütun) =toplam

neden olmadı? neden üst üste topladı?
Makro ve Kodları öğrenmek adına yardımlarınızı ve alternatif fikirlerinizi paylaşabilirseniz çok sevinirim.
Şimdiden çok teşekkür ederim.

halit3 · 14 Ağustos 2010

alternatif kod

Sub aktar()
For j = 2 To 6
For r = 3 To 14
bulunan1 = Sheets("Miktarlar").Cells(r, "a").Value
bulunan2 = Sheets("Miktarlar").Cells(2, j).Value
If bulunan1 & bulunan2 <> "" Then
say1 = 0
say2 = 0
For i = r To Worksheets("insört").Cells(Rows.Count, "B").End(3).Row
aranan1 = Val(Mid(Sheets("insört").Cells(i, "c").Value, 4, 2))
aranan2 = Sheets("insört").Cells(i, "d").Value
If bulunan1 & bulunan2 = aranan1 & aranan2 Then
say1 = say1 + CDbl(Sheets("insört").Cells(i, "N").Value)
say2 = say2 + 1
End If
Next i
Sheets("Miktarlar").Cells(r, j).Value = say1
Sheets("Miktarlar").Cells(r, j + 9).Value = say2
If Sheets("Miktarlar").Cells(r, j).Value = 0 Then
Sheets("Miktarlar").Cells(r, j).Value = ""
Sheets("Miktarlar").Cells(r, j + 9).Value = ""
End If
End If
Next r
Sheets("Miktarlar").Cells(16, j).Value = WorksheetFunction.Sum(Worksheets("Miktarlar").Range(Cells(2, j), Cells(14, j)))
Sheets("Miktarlar").Cells(16, j + 9).Value = WorksheetFunction.Sum(Worksheets("Miktarlar").Range(Cells(2, j + 9), Cells(14, j + 9)))
Next j
For m = 3 To 16
Sheets("Miktarlar").Cells(m, 8).Value = WorksheetFunction.Sum(Worksheets("Miktarlar").Range(Cells(m, 2), Cells(m, 6)))
Sheets("Miktarlar").Cells(m, 17).Value = WorksheetFunction.Sum(Worksheets("Miktarlar").Range(Cells(m, 11), Cells(m, 15)))
If Sheets("Miktarlar").Cells(m, 8).Value = 0 Then
Sheets("Miktarlar").Cells(m, 8).Value = ""
Sheets("Miktarlar").Cells(m, 17).Value = ""
End If
Next m
MsgBox "işlem tamam"
End Sub

Korhan Ayhan · 14 Ağustos 2010

Selamlar,

Ergün bey kısaca sorularınızı açıklamaya çalışayım;

1. Sorunuz;
Sizin tanımladığınız adlar olmasaydı aşağıdaki örnek koddaki gibi direk hücre adreslerini referans alabilirdik. Kırmızı renkli bölümleri kullanarak hücre adreslerini referans olarak aldık.

Burada kullandığımız Son_Satır değişkeni veri sayınıza göre değişecektir. Bunu şu amaçla kullandık. Ne kadar satır veriniz varsa Evaluate içinde kullandığımız SumProduct fonksiyonu o kadar satırı hesaplayacaktır. Buda kodların hızlı çalışmasını sağlayacaktır. Satır sayısnız arttıkça hesaplama işlemi yavaşlayacaktır.

Kod:

Option Explicit
 
Sub HESAPLA()
    Dim Satır As Integer, Sütun As Byte, Son_Satır As Long
 
    Application.ScreenUpdating = False
 
    [COLOR=red]Son_Satır[/COLOR] = Sheets("insört").Range("A65536").End(3).Row
 
    For Satır = 3 To 16
        If Satır <> 15 And Satır <> 16 Then
            For Sütun = 2 To 8
                If Sütun <> 7 And Sütun <> 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((MONTH([COLOR=red]insört!C3:C" & Son_Satır & "[/COLOR]))=" & Cells(Satır, 1) & ")*([COLOR=red]insört!D3:D" & Son_Satır & "[/COLOR]=""" & Cells(2, Sütun) & """)*([COLOR=red]insört!N3:N" & Son_Satır & "[/COLOR]))")
                    If Cells(Satır, Sütun) = 0 Then Cells(Satır, Sütun) = Empty
                ElseIf Sütun = 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((MONTH(insört!C3:C" & Son_Satır & "))=" & Cells(Satır, 1) & ")*(insört!N3:N" & Son_Satır & "))")
                    If Cells(Satır, Sütun) = 0 Then Cells(Satır, Sütun) = Empty
                End If
            Next
 
        ElseIf Satır = 16 Then
            For Sütun = 2 To 8
                If Sütun <> 7 And Sütun <> 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((YEAR(insört!C3:C" & Son_Satır & "))=" & Cells(Satır, 1) & ")*(insört!D3:D" & Son_Satır & "=""" & Cells(2, Sütun) & """)*(insört!N3:N" & Son_Satır & "))")
                    If Cells(Satır, Sütun) = 0 Then Cells(Satır, Sütun) = Empty
                ElseIf Sütun = 8 Then
                    Cells(Satır, Sütun) = Evaluate("=SUMPRODUCT(((YEAR(insört!C3:C" & Son_Satır & "))=" & Cells(Satır, 1) & ")*(insört!N3:N" & Son_Satır & "))")
                    If Cells(Satır, Sütun) = 0 Then Cells(Satır, Sütun) = Empty
                End If
            Next
        End If
    Next
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

2. Sorunuz;
Eğer kod içinde excelin yerleşik fonksiyonlarından destek almasaydık bu işlemi aşağıdaki yöntemlerle yapabilirdik. (Aklıma ilk gelen yöntemler)

Klasik For-Next Döngüsüyle (Veri sayısı arttıkça yavaş sonuç verir.)
Klasik For-Next Döngüsüyle + Filtreleme Yöntemiyle
Redim Komutu + For-Next Döngüsüyle
Özet Tablo Yöntemiyle (Tablo formatı sizin tablonuza benzemesede istediğimiz sonucu alabiliriz.)
Do-Loop-While Döngüsüyle + Find Komutu Kullanarak
ADO yada DAO sorgu yöntemleriyle

3. Sorunuz;
"i" döngüsünü yukarıda bahsettiğim diğer yöntemleri kullanarak sadeleştirebilirsiniz.

toplam = toplam + s1.Cells(i, 12)
s2.Cells(Satır, Sütun) = toplam

Bu kod bloğunu kullanmak isterseniz "toplam" değişkenini hücreye yazdırdıktan sonra (kırmızı renkli bölüm) sıfırlamanız gerekir. Yani aşağıdaki gibi bir satır kullanmanız gerekir. Aksi halde dediğiniz gibi sürekli koşula uyan değerleri üzerine ekleyeceği için istenilen sonucu vermez.

Kod:

toplam = toplam + s1.Cells(i, 12)
[COLOR=red]s2.Cells(Satır, Sütun) = toplam[/COLOR]
[COLOR=#ff0000]toplam = 0[/COLOR]

Makro kullanırken amacımız her zaman en kısa yoldan sonuca gitmek olmalıdır. Bunu yapabilmeniz içinde çeşitli yöntemleri kullanmayı bilmek gerekmektedir.

Siz kendi çözümünüzde klasik For-Next döngüsünü kullandığınız için kodlar daha yavaş çalışmaktadır. Bunu daha iyi anlamanız için aşağıdaki basit örneği inceleyiniz.

C sütununda 10.000 satır tarih içeren hücre var. (10.000 satır dememdeki amaç veri çokluğunda makronun tepkisini anlamanız içindir.)

Fakat sizin sorguladığınız tarih bu satırların içinde sadece 10 satırda bulunuyor. Siz klasik döngü yöntemi ile 10.000 satırı döngüye alıyorsunuz ve If sorgusu ile kendi tarihinizle döngüye aldığınız tarihleri kıyaslayıp işlem yapıyorsunuz. Makro sizin istediğiniz satırlara ulaşmak için mecburen 10.000 satırlık tarih içeren datayı satır satır sorgulayacaktır. İşte yavaşlama burada başlamaktadır. Bu yavaşlamayıda yukarıda bahsettiğim diğer yöntemleri kullanarak rahatlıkla aşabilirsiniz.

Ben hazırladığım makrolarda herzaman eğer imkanlar elveriyorsa excelin yerleşik işlevlerini kullanırım. Çünkü bu işlevleri oluşturan kişiler yazılım uzmanlarıdır. Size ve sizin gibi makrolara başlayan arkadaşlarımıda bu yöntemleri kullanmalarını tavsiye ederim.

Size farklı fikirler vermesi açısından DO-LOOP-WHILE + FIND komutları ile ilgili bir örnek makro daha hazırladım. Veri sayısını arttırarak şuana kadar hazırlanmış tüm kodların çalışma hızlarını test edebilirsiniz. Tabiki bunlara alternatif daha hızlı çalışan kodlarda yazılabilir.

Özellik Redim , Ado , Dao yöntemleri çok satırlı datalarda sisteminizin performansına bağlı olarak saniyeler içinde sonuç vermektedir. Forumda bunlarla ilgili birçok örnek bulunmaktadır.

Kod:

Option Explicit
 
Sub HESAPLA()
    Dim S1 As Worksheet, S2 As Worksheet, X As Byte, Y As Byte
    Dim Tarih As Date, İlk_Tarih As Date, Son_Tarih As Date
    Dim Bul As Range, Adres As String, WF As WorksheetFunction
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("insört")
    Set S2 = Sheets("Miktarlar")
    Set WF = WorksheetFunction
 
    S2.Range("B3:H16").ClearContents
 
    For X = 3 To 14
        İlk_Tarih = DateSerial(S2.Range("A16"), S2.Cells(X, "A"), 1)
        Son_Tarih = DateSerial(S2.Range("A16"), S2.Cells(X, "A") + 1, 0)
 
        For Tarih = İlk_Tarih To Son_Tarih
            Set Bul = S1.Range("C:C").Find(Tarih, , xlValues)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                For Y = 2 To 6
                    If Bul.Offset(0, 1) = S2.Cells(2, Y) Then
                        S2.Cells(X, Y) = S2.Cells(X, Y) + Bul.Offset(0, 11)
                        S2.Cells(16, Y) = WF.Sum(S2.Range(S2.Cells(3, Y), S2.Cells(14, Y)))
                    End If
                Next
            Set Bul = S1.Range("C:C").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        Next
 
        If WF.Sum(S2.Range("B" & X & ":F" & X)) = 0 Then
            S2.Cells(X, "H") = Empty
        Else
            S2.Cells(X, "H") = WF.Sum(S2.Range("B" & X & ":F" & X))
        End If
 
        S2.Cells(16, "H") = WF.Sum(S2.Range("B16:F16"))
    Next
 
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Ergün Güler · 15 Ağustos 2010

halit3' Alıntı:
alternatif kod

Selam Sayın Halit3,
Çözüm İçin çok teşekkür ederim. Gerçekten harika olmuş.

For i = r To Worksheets("insört").Cells(Rows.Count, "B").End(3).Row
aranan1 = Val(Mid(Sheets("insört").Cells(i, "c").Value, 4, 2))
aranan2 = Sheets("insört").Cells(i, "d").Value
If bulunan1 & bulunan2 = aranan1 & aranan2 Then
say1 = say1 + CDbl(Sheets("insört").Cells(i, "N").Value)
say2 = say2 + 1
End If

Kodlardaki kırmızı bölümleri biraz izah edebilirseniz çok sevinirim.

diğer bir sorum şu;

örnek dosyamdaki "Hızlar" adlı sayfada bir hücre içinde alt alta 3 farklı fonksiyon ile sonuç buluyorum. Bu sayfanın tamamını makro ile nasıl yapabilirim?

İyi çalışmalar.

Ergün Güler · 15 Ağustos 2010

Korhan Ayhan' Alıntı:
Selamlar,

Ergün bey kısaca sorularınızı açıklamaya çalışayım;

Sayın Korhan Ayhan,
Birden fazla alternatif çözümleriniz ve akıcı izahlarınız içimgerçekten çok çok teşekkür ederim.

sizin öneri ve tavsiyelerinize uyacağım.
Ayrıca,

Redim Komutu + For-Next Döngüsüyle
Do-Loop-While Döngüsüyle + Find Komutu Kullanarak
ADO yada DAO sorgu yöntemleriyle

ilgili araştırma ve çalışmalar yapmam gerekiyor. Sizin önerebileceğiniz link, dosya v.s. varsa şimdiden çok teşşekür ederim.
İyi çalışmalar.

halit3 · 15 Ağustos 2010

Dilimin dödüğünce açıklıyayım.

aranan1 = Val(Mid(Sheets("insört").Cells(i, "c").Value, 4, 2))
burada ilgili ayı bulmak için parçaal fonksiyonunu kallandık.

say1 = say1 + CDbl(Sheets("insört").Cells(i, "N").Value)
burada excelin Conversion komutunda CDbl yani değerleri sayılara dönüştürdük

siğer sorun içinde kod yazdım ancak veriler çoğaldıkca kod yavaşlıyacaktır.

Korhan Beyin uyguladığı mantıktan kodları düzenlerseniz daha hızlı verileri alırsınız.

Ergün Güler · 17 Ağustos 2010

halit3' Alıntı:
Dilimin dödüğünce açıklıyayım.

aranan1 = Val(Mid(Sheets("insört").Cells(i, "c").Value, 4, 2))
burada ilgili ayı bulmak için parçaal fonksiyonunu kallandık.

say1 = say1 + CDbl(Sheets("insört").Cells(i, "N").Value)
burada excelin Conversion komutunda CDbl yani değerleri sayılara dönüştürdük

siğer sorun içinde kod yazdım ancak veriler çoğaldıkca kod yavaşlıyacaktır.

Korhan Beyin uyguladığı mantıktan kodları düzenlerseniz daha hızlı verileri alırsınız.

Selam Sayın Halit3,
Ellerinize sağlık. Ekteki Hızlar ile ilgili çözümü inceledim. Mükemmel olmuş ancak, bir problem var. ortalamaları yanlış hesaplıyor. Mak ve Min'ler doğru
Siz sadece insört sayfasındaki M sütunundaki Hızları, Adetlerden bağımsız ortalamasını alıyorsunuz.
istenilen ortalama şöyle olması gerekiyor.
mesela;

50.000 hızda 60.000 adet
40.000 hızda 90.000 adet
60.000 hızda 120.000 adet

ise
50.000 * 60.000 adet= 3.000.000.000
40.000 * 90.000 adet=3.600.000.000
60.000 * 120.000 adet=7.200.000.000
toplam: 13.800.000.000

13.800.000.000/270.000= 51.111,11

ortalama hız 51.111 'dir
270.000 rakamı adetlerin toplamıdır.

Ancak size göre 50.000+40.000+60.000=150.000/3=50.000 ortalama hızdır.

Neden böyle bir ortalama kullanıyorum, izah edeyim;
örnek bir araba

50.000 hızda 60.000 metre
40.000 hızda 90.000 metre
60.000 hızda 120.000 metre
yol aldığını düşünürsek

toplamda aldığı yol 270.000(=60+90+120) metreyi ortlama 51.111 hızda almış demektir.
Ben sizin kodlarınız üzerinde biraz çalıştım. Ancak beceremedim. yardımcı olabilirseniz sevinirim.

bir kaç soru;
-bir hücre içine 3 ayrı sonucu hangi kodlar ile sağlıyorsunuz?
-bulunan sonuçları 50000 değilde 50.000 şeklinde nasıl yapabiliriz?
-Bulunan sonuçlar 50.000 rakamının yanına 50.000 min, mak,ort metinlerini nasıl ekleyebiliriz?

Şimdiden çok teşekkür ederim.
İyi çalışmalar.

halit3 · 17 Ağustos 2010

ortalama hız hesaplaması mantıken aynı tam sonuç vermesi gerekiyor ister sizin hesapladığınız şekilde olsun isterse benim hesaplamalarımda olsun genel toplamı adete bölerek buluyoruz ortalamayı sonuç aynı

diğer sorın içinde aşağıdaki kodu incele

Sub aktar2()
For j = 2 To 6
For r = 3 To 14
bulunan1 = Sheets("Miktarlar").Cells(2, j).Value
bulunan2 = Sheets("Miktarlar").Cells(r, "a").Value
say1 = 0: say2 = 0: say3 = 0: sat1 = 0
say4 = 0: say5 = 0: say6 = 0: sat2 = 0
say7 = 0: say8 = 0: say9 = 0: sat3 = 0
For i = 3 To Worksheets("insört").Cells(Rows.Count, "B").End(3).Row
aranan1 = Sheets("insört").Cells(i, "d").Value
aranan2 = Val(Mid(Sheets("insört").Cells(i, "c").Value, 4, 2))
If bulunan1 & bulunan2 = aranan1 & aranan2 Then
sat1 = sat1 + 1
If sat1 = 1 Then
say1 = CDbl(Sheets("insört").Cells(i, "M").Value)
End If
deg1 = CDbl(Sheets("insört").Cells(i, "M").Value)
say2 = say2 + CDbl(Sheets("insört").Cells(i, "M").Value)
If say3 > deg1 Then
say3 = say3
Else
say3 = deg1
End If
If say1 < deg1 Then
say1 = say1
Else
say1 = deg1
End If
End If
If bulunan1 = aranan1 Then
sat2 = sat2 + 1
If sat2 = 1 Then
say4 = CDbl(Sheets("insört").Cells(i, "M").Value)
End If
deg2 = CDbl(Sheets("insört").Cells(i, "M").Value)
say5 = say5 + CDbl(Sheets("insört").Cells(i, "M").Value)
If say6 > deg2 Then
say6 = say6
Else
say6 = deg2
End If
If say4 < deg2 Then
say4 = say4
Else
say4 = deg2
End If
End If
If bulunan2 = aranan2 Then
sat3 = sat3 + 1
If sat3 = 1 Then
say7 = CDbl(Sheets("insört").Cells(i, "M").Value)
End If
deg3 = CDbl(Sheets("insört").Cells(i, "M").Value)
say8 = say8 + CDbl(Sheets("insört").Cells(i, "M").Value)
If say9 > deg3 Then
say9 = say9
Else
say9 = deg3
End If
If say7 < deg3 Then
say7 = say7
Else
say7 = deg3
End If
End If
Next i

On Error Resume Next
Sheets("Hızlar").Cells(r, j + 1).Value = Format(say1, "#,###") & " Min" & Chr(10) & Format(Val((say2 / sat1)), "#,###") & " Ort" & Chr(10) & Format(say3, "#,###") & " Max"
Sheets("Hızlar").Cells(16, j + 1).Value = Format(say4, "#,###") & " Min" & Chr(10) & Format(Val((say5 / sat2)), "#,###") & " Ort" & Chr(10) & Format(say6, "#,###") & " Max"
Sheets("Hızlar").Cells(r, 9).Value = Format(say7, "#,###") & " Min" & Chr(10) & Format(Val((say8 / sat3)), "#,###") & " Ort" & Chr(10) & Format(say9, "#,###") & " Max"
Next r
Next j
sonsat = Worksheets("insört").Cells(Rows.Count, "M").End(xlUp).Row
yer1 = Val(WorksheetFunction.Min(Worksheets("insört").Range("M1:M" & sonsat)))
yer2 = Val(WorksheetFunction.Average(Worksheets("insört").Range("M1:M" & sonsat)))
yer3 = Val(WorksheetFunction.Max(Worksheets("insört").Range("M1:M" & sonsat)))
Cells(16, 9) = Format(yer1, "#,###") & " Min" & Chr(10) & Format(yer2, "#,###") & " Ort" & Chr(10) & Format(yer3, "#,###") & " Max"

MsgBox "işlem tamam"
End Sub

Ergün Güler · 17 Ağustos 2010

Selam, Sayın Halit3,
İlginize ve çözümlerinize çok teşekkür ederim. Ellerinize sağlık. Sayenizde çok şey öğreniyorum. Sorduğum son 2 sorunun (format v.s.) cevabı için ayrıca çok teşekkür ederim.
Son verdiğiniz kod ile doğru ortalama hızı yine bulamadım. Ortalama Hızı size tam olarak anlatamadığım için özür dilerim.
Ancak, ben de sizin daha önceden verdiğiniz kodları biraz değiştirdim ve Ortalam hızları tam istediğim gibi buldum. Kodlar aşağıdadır.
Daha önce verdiğiniz koddaki for i = r To.. kısımndaki r'yi 3 yaptım.
M1'ler M3 yaptım. ortalama bulmak için Say2,Say5 ve Say8 iptal edip yerine ayrıca kodlar yazdım.
1.mesajımdaki örnek dosyamdaki "hızlar" sayfasını incelerseniz ortalama hızların aynı olduğu göreceksiniz.
(bir önceki mesajımda bahsettiğim araba örneği gibi)

Kod:

Sub aktar2()
For j = 3 To 7
For r = 3 To 14
Set s1 = Worksheets("insört")
Set s2 = Worksheets("Hızlar")
aranan1 = s2.Cells(2, j).Value
aranan2 = s2.Cells(r, "a").Value

say1 = 0:  say3 = 0: sat1 = 0
say4 = 0:  say6 = 0: sat2 = 0
say7 = 0:  say9 = 0: sat3 = 0
miktar1 = 0: toplam1 = 0: ort1 = 0
miktar2 = 0: toplam2 = 0: ort2 = 0
miktar3 = 0: toplam3 = 0: ort3 = 0

For i = 3 To s1.Cells(Rows.Count, "B").End(3).Row
bulunan1 = s1.Cells(i, "d").Value
bulunan2 = Val(Mid(s1.Cells(i, "c").Value, 4, 2))

If aranan1 & aranan2 = bulunan1 & bulunan2 Then
sat1 = sat1 + 1
If sat1 = 1 Then
say1 = CDbl(s1.Cells(i, "M").Value)
End If

deg1 = CDbl(s1.Cells(i, "M").Value)
miktar1 = miktar1 + CDbl(s1.Cells(i, "N").Value)
toplam1 = toplam1 + CDbl(s1.Cells(i, "M").Value) * CDbl(s1.Cells(i, "N").Value)
ort1 = toplam1 / miktar1

If say3 > deg1 Then
say3 = say3
Else
say3 = deg1
End If

If say1 < deg1 Then
say1 = say1
Else
say1 = deg1
End If
End If

If aranan1 = bulunan1 Then
sat2 = sat2 + 1
If sat2 = 1 Then
say4 = CDbl(s1.Cells(i, "M").Value)
End If
deg2 = CDbl(s1.Cells(i, "M").Value)
miktar2 = miktar2 + CDbl(s1.Cells(i, "N").Value)
toplam2 = toplam2 + CDbl(s1.Cells(i, "M").Value) * CDbl(s1.Cells(i, "N").Value)
ort2 = toplam2 / miktar2

If say6 > deg2 Then
say6 = say6
Else
say6 = deg2
End If
If say4 < deg2 Then
say4 = say4
Else
say4 = deg2
End If
End If

If aranan2 = bulunan2 Then
sat3 = sat3 + 1
If sat3 = 1 Then
say7 = CDbl(s1.Cells(i, "M").Value)
End If
deg3 = CDbl(s1.Cells(i, "M").Value)
miktar3 = miktar3 + CDbl(s1.Cells(i, "N").Value)
toplam3 = toplam3 + CDbl(s1.Cells(i, "M").Value) * CDbl(s1.Cells(i, "N").Value)
ort3 = toplam3 / miktar3

If say9 > deg3 Then
say9 = say9
Else
say9 = deg3
End If
If say7 < deg3 Then
say7 = say7
Else
say7 = deg3
End If
End If

Next i

On Error Resume Next
s2.Cells(r, j).Value = say1 & Chr(10) & Val(ort1) & Chr(10) & say3
s2.Cells(16, j).Value = say4 & Chr(10) & Val(ort2) & Chr(10) & say6
s2.Cells(r, 9).Value = say7 & Chr(10) & Val(ort3) & Chr(10) & say9

Next r
Next j

sonsat = s1.Cells(Rows.Count, "M").End(xlUp).Row
yer1 = Val(WorksheetFunction.Min(s1.Range("M3:M" & sonsat)))
tc = WorksheetFunction.SumProduct(s1.Range("M3:M" & sonsat), s1.Range("n3:n" & sonsat))
mk = WorksheetFunction.Sum(s1.Range("n3:n" & sonsat))
yer2 = Val(tc / mk)

yer3 = Val(WorksheetFunction.Max(s1.Range("M3:M" & sonsat)))
Cells(16, 9) = yer1 & Chr(10) & yer2 & Chr(10) & yer3


MsgBox "işlem tamam"

Range("A1:K20").AutoFit

End Sub

1.sorum;
Yukarıda kodlar ile bulunan sonuçlarda 0 olan makro ile nasıl boş gösterebilirim?

2.sorum;
Sizin son verdiğiniz koda

Range("A1:K20").AutoFit

eklediğimde neden tam olarak autofit yapamıyorum?
min, mak, ort eklerini dahil etmiyor mu?

3.sorum;
Anladığım kadarıyla, Kodlardaki Chr(10), 2. ve 3.değerleri alt satıra geçiriyor.
Peki 10 rakamı karakter sayısı değil midir? 10'dan aşağı veya yukarı sayı verdiğimde hücre içi karışıyor. Chr(10) içindeki 10 sayısı neyi ifade ediyor?

İyi çalışmalar.

halit3 · 17 Ağustos 2010

örnek olarak bir kaç tane yaptım kırmızı yazıların arasını koyacaksın sıfır değerler varsa boş bırakacak.

Next i
If say1 = 0 Then say1 = ""
If say4 = 0 Then say4 = ""
If say7 = 0 Then say 7 = ""
If ort1 = 0 Then ort1 = ""

On Error Resume Next

halit3 · 17 Ağustos 2010

kodun çalışması için 20 satırdan sonra mutlaka 1 satır boş olmalı

Selection.AutoFilter
Range("A1:K20").AutoFilter

halit3 · 17 Ağustos 2010

Chr(10)
alt + enter tuşunun yaptığı vazifeyi yapar.

Ergün Güler · 17 Ağustos 2010

halit3' Alıntı:
kodun çalışması için 20 satırdan sonra mutlaka 1 satır boş olmalı

Selam Sayın Halit3,
Açıklamalarınız için çok teşekkür ederim.

Yapamadığım Autofilter değil autofit idi. 10.mesajdaki sizin kodlar ile sağlıklı autofit yapamıyorum.
Çünkü bu sayfada başka sonuçlarda görüntülüyorum. sizin kodları çalıştırdığımda satır ve sütunların otomatik fit'lenmesini istiyorum. Sağlıklı yapamadım.
İyi çalışmalar.

Korhan Ayhan · 17 Ağustos 2010

Selamlar,

Sütun genişliklerini otomatik ayarlamak için aşağıdaki kodu kullanabilirsiniz.

Kod:

Columns("A:K").EntireColumn.AutoFit 'Sütunlar
Rows("1:20").EntireRow.AutoFit 'Satırlar

Ergün Güler · 18 Ağustos 2010

Korhan Ayhan' Alıntı:
Selamlar,

Sütun genişliklerini otomatik ayarlamak için aşağıdaki kodu kullanabilirsiniz.

Kod:

Columns("A:K").EntireColumn.AutoFit 'Sütunlar Rows("1:20").EntireRow.AutoFit 'Satırlar

Selam sayın Korhan Ayhan,
Çok teşekkür ederim. Dediğiniz doğrudur ancak, sayın Halit3'ün 10.mesajındaki kodlara uyguladığımda otomatik sığdırmıyor yani galiba rakamdan sonraki metinleri autofit yapamıyor. Diğer kodlarda sizin dediğinizi uyguladım pek ala yapabiliyor.
Pek konu ile alakası olmayabilir ama WorksheetFunction. dan sonra If yani EĞER komutunu bulamadım. Neden bazı excel fonksiyonlarına karşılık gelen kodları WorksheetFunction. altında bulamıyorum?
İyi çalışmalar.

Orion1 · 18 Ağustos 2010

Ergün Güler' Alıntı:
Pek konu ile alakası olmayabilir ama WorksheetFunction. dan sonra If yani EĞER komutunu bulamadım. Neden bazı excel fonksiyonlarına karşılık gelen kodları WorksheetFunction. altında bulamıyorum?
İyi çalışmalar.

VBA'da if komutu yerleşik fonksiyondaki if fonksiyonunhdan çok daha esnektir.
Onun için iyisi varken daha az fonksiyonel bir şeyi koymamış ms.Bence haklıda.Siz iyisi varken kötüsünü kullanırmısınız.
Ayrıca iif var vba komutu.Oda ayni if fonksiyonu gibidir.
İsterseniz onu kulanın.
Aşağıdaki iif komutu A1 hücresinin içindeki değerin ne olduğunu sorguluyor.

Kod:

MsgBox IIf(Range("A1").Value = "", "A1 Hücresi Boş", _
IIf(IsDate(Range("A1").Value), "A1 Hücresi Tarihtir.", _
IIf(IsNumeric(Range("A1").Value), "A1 hücresi sayı", "A1 Hücresi string")))

Ergün Güler · 18 Ağustos 2010

Evren Gizlen' Alıntı:
VBA'da if komutu yerleşik fonksiyondaki if fonksiyonunhdan çok daha esnektir.
Onun için iyisi varken daha az fonksiyonel bir şeyi koymamış ms.Bence haklıda.Siz iyisi varken kötüsünü kullanırmısınız.
Ayrıca iif var vba komutu.Oda ayni if fonksiyonu gibidir.
İsterseniz onu kulanın.
Aşağıdaki iif komutu A1 hücresinin içindeki değerin ne olduğunu sorguluyor.

Kod:

MsgBox IIf(Range("A1").Value = "", "A1 Hücresi Boş", _ IIf(IsDate(Range("A1").Value), "A1 Hücresi Tarihtir.", _ IIf(IsNumeric(Range("A1").Value), "A1 hücresi sayı", "A1 Hücresi string")))

Selam Sayın Evren Gizlen,
İlgi, alakanız ve yardımlarınız için çok teşekkür ederim. Sayenizde çok şey öğreniyorum. Öğrendikçe Excel, Makro ,VBA gitdide gözümde çok büyüyor.

bir boş kod sayfasına "IIF(" yazınca bunun bir kod olduğu anlaşılıyor.
peki benzeri kodları bulabilmek için ne yapmamız gerekiyor?
örneğin ben
Object Browser'dan library'den VBA seçiyorum. alttaki sağdaki pencerede liste beliriyor. bu pencerenin üstünde members of <globals> bunun altındakiler hepsi VBA kodlarıdır Doğru mudur?
bu kodların üzerine iken sağa tıklayıp "help" tıklıyorum ingilizce yardım menüleri çıkıyor. burada kodların nasıl kullanılacağını örnekler ile beraber anlatıyor. Doğru yol üzerinde miyim?
Object Browser'dan library'den Excel seçiyorum. members of <globals> listesinden "worksheetfunction" ı bulup seçiyorum. en alttaki pencereden yeşil renkli "worksheetfunction" yazısına tıklayınca bu kod içinde kullanılan ayrıca kodları bulabiliyorum. peki bu kodlar neden ilk library'den excel'i seçince çıkmadı?
bazı kodlarda değişik semboller var. kimi silgiye benzer yeşil renkli kimi zarf tutan el gibi kimi ise gri renkli diktörgen içinde = işaretli.
yeşil silgi gibiler kod
zarf tutan el gibiler kod grubu
gri renkli olanlar mesaj, uyarı v.s. midir?

yine konu ile alakası olmaya bilir ama for-next ile dizi oluşturmaya çalışıyorum.

Kod:

Sub makro1()

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = s1.Range("A65536").End(3).Row

dizi = 0
For i = 3 To son

If s1.Cells(i, "D") = s2.Cells(2, "C") Then
dizi = dizi & "," & s1.Cells(i, "M")
End If
Next i

s2.Cells(5, "K") = dizi
s2.Cells(6, "K") = WorksheetFunction.Max(dizi)

End Sub

Ancak hata veriyor.

Kod:

s2.Cells(5, "K") = dizi

ile K5 hücresinde diziyi görebiliyorum. 0,15000,20000,30000 gibi

Kod:

s2.Cells(6, "K") = WorksheetFunction.Max(dizi)

ile neden dizinin max'ını bulamıyorum.
Dizi yerine el ile 0,15000,20000,30000 yazarsam maksimumu bulabiliyorum.
Maksadım sadece maksimumu bulmak değil. Benzeri konularda oluşturduğum diziyi kullanabilmek.
Yardımcı olabilirseniz çok sevinirim.
Şimdiden çok teşekkür ederim.

Ergün Güler · 29 Ağustos 2010

Selam Sayın Evren Gizlen,
19.sıradaki mesajımı okumuş muyudunuz?
Yardımcı olabilirseniz çok sevinirim.
İyi çalışmalar.

İki koşula uyanların toplamlarını alma

Ergün Güler

Ekli dosyalar

Korhan Ayhan

Administrator

Ergün Güler

halit3

Uzman

Korhan Ayhan

Administrator

Ergün Güler

Ergün Güler

halit3

Uzman

Ekli dosyalar

Ergün Güler

halit3

Uzman

Ergün Güler

halit3

Uzman

halit3

Uzman

halit3

Uzman

Ergün Güler

Korhan Ayhan

Administrator

Ergün Güler

Orion1

Uzman

Ergün Güler

Ergün Güler