• DİKKAT

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

Aylar itibariyle maksimum puanları yazdırma

  • Konbuyu başlatan Konbuyu başlatan Gamma
  • Başlangıç tarihi Başlangıç tarihi
G

Gamma

Katılım
4 Ocak 2012
Mesajlar
54
Excel Vers. ve Dili
Excel 2007 Türkçe
Merhaba,
Aşağıdaki işlemi yapabilmek için bir VBA koduna ihtiyacım var. Yardımcı olabilirseniz çok memnun olurum. Şimdiden teşekkür ederim.
Aslında bana lazım olan iki farklı kod var:
Birincisi:
Excelde A sütununda Ay/gün/yıl olmak üzere tarihler, B, C ve D sütunlarında da isimler var. İlgili hücrelerde her ismin A sütununda belirtilen gündeki puanı yer alıyor.
Kodun yapmasını istediğim ise her ay için B,C ve D sütunlarında isimleri bulunan kişilerin maksimum puanını başka bir sayfaya ilgili aylar itibariyle yazdırmak.
İkincisi ise;
her kişinin ilgili aydaki en yüksek 3 puanının ortalamasını başka bir sayfaya ilgili aylar itibariyle yazdırmak.

İlgilenen arkadaşlara tekrar teşekkür ederim.
 
Merhaba,
Gerçek dosyanızla birebir aynı olan örnek bir dosya eklerseniz istediğiniz herhangi bir yöntem ile çözüm üretilebilir
 
Merhaba,
Deneyiniz...
Olmazsa dosya ekleyiniz.
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range, a2 As Range, a3 As Range
Dim s1 As Worksheet

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
ReDim dz(1 To s, 1 To 7)
x = 1
dz(x, 1) = "AY"
dz(x, 2) = Range("B1") & vbLf & "MAK"
dz(x, 3) = Range("B1") & vbLf & "MAK3ORT"
dz(x, 4) = Range("C1") & vbLf & "MAK"
dz(x, 5) = Range("C1") & vbLf & "MAK3ORT"
dz(x, 6) = Range("D1") & vbLf & "MAK"
dz(x, 7) = Range("D1") & vbLf & "MAK3ORT"

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        Set a1 = Range("B" & bas & ":B" & bit)
        Set a2 = Range("C" & bas & ":C" & bit)
        Set a3 = Range("D" & bas & ":D" & bit)
       
        x = x + 1
        dz(x, 1) = ay
        dz(x, 2) = WorksheetFunction.Max(a1)
        dz(x, 3) = WorksheetFunction.AverageIf(a1, ">=" & WorksheetFunction.Large(a1, 3), a1)
        dz(x, 4) = WorksheetFunction.Max(a2)
        dz(x, 5) = WorksheetFunction.AverageIf(a2, ">=" & WorksheetFunction.Large(a2, 3), a2)
        dz(x, 6) = WorksheetFunction.Max(a3)
        dz(x, 7) = WorksheetFunction.AverageIf(a3, ">=" & WorksheetFunction.Large(a3, 3), a3)
       
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub
 
ÖmerBey' Alıntı:
Merhaba,
Deneyiniz...
Olmazsa dosya ekleyiniz.
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range, a2 As Range, a3 As Range
Dim s1 As Worksheet

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
ReDim dz(1 To s, 1 To 7)
x = 1
dz(x, 1) = "AY"
dz(x, 2) = Range("B1") & vbLf & "MAK"
dz(x, 3) = Range("B1") & vbLf & "MAK3ORT"
dz(x, 4) = Range("C1") & vbLf & "MAK"
dz(x, 5) = Range("C1") & vbLf & "MAK3ORT"
dz(x, 6) = Range("D1") & vbLf & "MAK"
dz(x, 7) = Range("D1") & vbLf & "MAK3ORT"

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        Set a1 = Range("B" & bas & ":B" & bit)
        Set a2 = Range("C" & bas & ":C" & bit)
        Set a3 = Range("D" & bas & ":D" & bit)
      
        x = x + 1
        dz(x, 1) = ay
        dz(x, 2) = WorksheetFunction.Max(a1)
        dz(x, 3) = WorksheetFunction.AverageIf(a1, ">=" & WorksheetFunction.Large(a1, 3), a1)
        dz(x, 4) = WorksheetFunction.Max(a2)
        dz(x, 5) = WorksheetFunction.AverageIf(a2, ">=" & WorksheetFunction.Large(a2, 3), a2)
        dz(x, 6) = WorksheetFunction.Max(a3)
        dz(x, 7) = WorksheetFunction.AverageIf(a3, ">=" & WorksheetFunction.Large(a3, 3), a3)
      
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub
Genişletmek için tıkla ...


çok teşekkür ederim hemen deniyorum
 
ÖmerBey' Alıntı:
Merhaba,
Deneyiniz...
Olmazsa dosya ekleyiniz.
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range, a2 As Range, a3 As Range
Dim s1 As Worksheet

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
ReDim dz(1 To s, 1 To 7)
x = 1
dz(x, 1) = "AY"
dz(x, 2) = Range("B1") & vbLf & "MAK"
dz(x, 3) = Range("B1") & vbLf & "MAK3ORT"
dz(x, 4) = Range("C1") & vbLf & "MAK"
dz(x, 5) = Range("C1") & vbLf & "MAK3ORT"
dz(x, 6) = Range("D1") & vbLf & "MAK"
dz(x, 7) = Range("D1") & vbLf & "MAK3ORT"

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        Set a1 = Range("B" & bas & ":B" & bit)
        Set a2 = Range("C" & bas & ":C" & bit)
        Set a3 = Range("D" & bas & ":D" & bit)
      
        x = x + 1
        dz(x, 1) = ay
        dz(x, 2) = WorksheetFunction.Max(a1)
        dz(x, 3) = WorksheetFunction.AverageIf(a1, ">=" & WorksheetFunction.Large(a1, 3), a1)
        dz(x, 4) = WorksheetFunction.Max(a2)
        dz(x, 5) = WorksheetFunction.AverageIf(a2, ">=" & WorksheetFunction.Large(a2, 3), a2)
        dz(x, 6) = WorksheetFunction.Max(a3)
        dz(x, 7) = WorksheetFunction.AverageIf(a3, ">=" & WorksheetFunction.Large(a3, 3), a3)
      
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub
Genişletmek için tıkla ...
Çok çok teşekkürler harika çalıştı
 
ÖmerBey' Alıntı:
Merhaba,
Deneyiniz...
Olmazsa dosya ekleyiniz.
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range, a2 As Range, a3 As Range
Dim s1 As Worksheet

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
ReDim dz(1 To s, 1 To 7)
x = 1
dz(x, 1) = "AY"
dz(x, 2) = Range("B1") & vbLf & "MAK"
dz(x, 3) = Range("B1") & vbLf & "MAK3ORT"
dz(x, 4) = Range("C1") & vbLf & "MAK"
dz(x, 5) = Range("C1") & vbLf & "MAK3ORT"
dz(x, 6) = Range("D1") & vbLf & "MAK"
dz(x, 7) = Range("D1") & vbLf & "MAK3ORT"

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        Set a1 = Range("B" & bas & ":B" & bit)
        Set a2 = Range("C" & bas & ":C" & bit)
        Set a3 = Range("D" & bas & ":D" & bit)
    
        x = x + 1
        dz(x, 1) = ay
        dz(x, 2) = WorksheetFunction.Max(a1)
        dz(x, 3) = WorksheetFunction.AverageIf(a1, ">=" & WorksheetFunction.Large(a1, 3), a1)
        dz(x, 4) = WorksheetFunction.Max(a2)
        dz(x, 5) = WorksheetFunction.AverageIf(a2, ">=" & WorksheetFunction.Large(a2, 3), a2)
        dz(x, 6) = WorksheetFunction.Max(a3)
        dz(x, 7) = WorksheetFunction.AverageIf(a3, ">=" & WorksheetFunction.Large(a3, 3), a3)
    
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub
Genişletmek için tıkla ...

Acaba bunu sadece 3 isim için değil de B,C,D,E ... şeklinde daha çok isimli hale getirmek mümkün olabilir mi? yani sütunlar bitene kadar devam edecek şekilde.
Bir de bazı kişilerin puanları ilk tarihlerde yok, o zaman kodun çalışmadığını farkettim. Bu sorun nasıl aşılabilir acaba?
Biraz fazla şey istediğimi düşünürseniz size hak veririm doğrusu, söyleyecek sözüm yok ben başaramadım.
Değerli bilginizi benimle paylaştığınız için tekrar çok çok teşekkür ediyorum.
 
Son düzenleme:
Buyurunuz...
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range
Dim s1 As Worksheet
Dim b As Integer, c As Integer

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
c = Cells(1, Columns.Count).End(1).Column
ReDim dz(1 To s, 1 To c * 2 - 1)
x = 1
dz(x, 1) = "AY"
For b = 1 To c - 1
    dz(x, b * 2) = Cells(1, b + 1) & vbLf & "MAK"
    dz(x, b * 2 + 1) = Cells(1, b + 1) & vbLf & "MAK3ORT"
Next

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        x = x + 1
        dz(x, 1) = ay
        For b = 1 To c - 1
            Set a1 = Range(Cells(bas, b + 1), Cells(bit, b + 1))
            dz(x, b * 2) = Application.Max(a1)
            dz(x, b * 2 + 1) = Application.IfError(Application.AverageIf(a1, ">=" & Application.IfError(Application.Large(a1, 3), 0), a1), 0)
        Next
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub
 
ÖmerBey' Alıntı:
Buyurunuz...
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range
Dim s1 As Worksheet
Dim b As Integer, c As Integer

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
c = Cells(1, Columns.Count).End(1).Column
ReDim dz(1 To s, 1 To c * 2 - 1)
x = 1
dz(x, 1) = "AY"
For b = 1 To c - 1
    dz(x, b * 2) = Cells(1, b + 1) & vbLf & "MAK"
    dz(x, b * 2 + 1) = Cells(1, b + 1) & vbLf & "MAK3ORT"
Next

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        x = x + 1
        dz(x, 1) = ay
        For b = 1 To c - 1
            Set a1 = Range(Cells(bas, b + 1), Cells(bit, b + 1))
            dz(x, b * 2) = Application.Max(a1)
            dz(x, b * 2 + 1) = Application.IfError(Application.AverageIf(a1, ">=" & Application.IfError(Application.Large(a1, 3), 0), a1), 0)
        Next
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub
Genişletmek için tıkla ...

Çok çok teşekkür ederim
 
Rica ederim,
İyi çalışmalar...
 
Ömer bey yazdığınız koda bakarak bir şeyler öğrenmeye çalışıyorum anlayabildiğim kadarıyla. Alınan ortalamanın en yüksek 3 değer olduğunu belirten satır hangisi acaba? Orayı 2, 5 ya da başka bir sayı ile değiştirecek farklı uyarlamalar yapmaya çalışacağım mümkünse. Onu öğrenirsem belki ortalamalı olanı bir sayfaya, ortalamasız olanı da başka bir sayfaya hesaplatabilirim diye de düşündüm.
 
Aşağıdaki satırdaki kırmızı rakam.
Rich (BB code): 
dz(x, b * 2 + 1) = Application.IfError(Application.AverageIf(a1, ">=" & Application.IfError(Application.Large(a1, 3), 0), a1), 0)
Burasını aşağıdaki formülün vba karşılığı olarak düşünebilirsiniz. Tabi A:A yerine dinamik aralık (a1) kullanılıyor. Bu şekilde daha anlaşılır olabilir.
Rich (BB code): 
=EĞERHATA(EĞERORTALAMA(A:A;">="&EĞERHATA(BÜYÜK(A:A;3);0);A:A);0)
İlave olarak verileri farklı sayfalara almak istiyorsanız daha farklı değişiklikler yapmak gerek.
 
ÖmerBey' Alıntı:
Aşağıdaki satırdaki kırmızı rakam.
Rich (BB code): 
dz(x, b * 2 + 1) = Application.IfError(Application.AverageIf(a1, ">=" & Application.IfError(Application.Large(a1, 3), 0), a1), 0)
Burasını aşağıdaki formülün vba karşılığı olarak düşünebilirsiniz. Tabi A:A yerine dinamik aralık (a1) kullanılıyor. Bu şekilde daha anlaşılır olabilir.
Rich (BB code): 
=EĞERHATA(EĞERORTALAMA(A:A;">="&EĞERHATA(BÜYÜK(A:A;3);0);A:A);0)
İlave olarak verileri farklı sayfalara almak istiyorsanız daha farklı değişiklikler yapmak gerek.
Genişletmek için tıkla ...
Çok sağolun. Ben verileri amatör işi bir kodla başka sayfalara kes yapıştırla ayırırım o zaman çünkü bu yaptığınız çok güzel çalışıyor hiç değiştirmeye çalışmayayım zaten da yapabileceğim bir şey değil anlaşılan. Çok çok teşekkürler tekrar
 
Aşağıdaki şekilde kullanabilirsiniz.
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range
Dim s1 As Worksheet
Dim b As Integer, c As Integer

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
c = Cells(1, Columns.Count).End(1).Column
ReDim dz1(1 To s, 1 To c)
ReDim dz2(1 To s, 1 To c)
x = 1
dz1(x, 1) = "AY"
dz2(x, 1) = "AY"
For b = 2 To c
    dz1(x, b) = Cells(1, b) & vbLf & "MAK"
    dz2(x, b) = Cells(1, b) & vbLf & "MAK3ORT"
Next

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        x = x + 1
        dz1(x, 1) = ay
        dz2(x, 1) = ay
        For b = 2 To c
            Set a1 = Range(Cells(bas, b), Cells(bit, b))
            dz1(x, b) = Application.Max(a1)
            dz2(x, b) = Application.IfError(Application.AverageIf(a1, ">=" & Application.IfError(Application.Large(a1, 3), 0), a1), 0)
        Next
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz1), UBound(dz1, 2)).Value = dz1

Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz2), UBound(dz2, 2)).Value = dz2
End Sub
 
ÖmerBey' Alıntı:
Aşağıdaki şekilde kullanabilirsiniz.
C#: 
Sub kod()
Dim ay As String
Dim bas As Long, s As Long, bit As Long, a As Long, x As Long
Dim a1 As Range
Dim s1 As Worksheet
Dim b As Integer, c As Integer

ay = Format(Range("A2"), "yyyy-mmmm")
bas = 2
s = Cells(Rows.Count, "A").End(3).Row
c = Cells(1, Columns.Count).End(1).Column
ReDim dz1(1 To s, 1 To c)
ReDim dz2(1 To s, 1 To c)
x = 1
dz1(x, 1) = "AY"
dz2(x, 1) = "AY"
For b = 2 To c
    dz1(x, b) = Cells(1, b) & vbLf & "MAK"
    dz2(x, b) = Cells(1, b) & vbLf & "MAK3ORT"
Next

For a = bas To s + 1
    If Format(Cells(a, 1), "yyyy-mmmm") <> ay Then
        bit = a - 1
        x = x + 1
        dz1(x, 1) = ay
        dz2(x, 1) = ay
        For b = 2 To c
            Set a1 = Range(Cells(bas, b), Cells(bit, b))
            dz1(x, b) = Application.Max(a1)
            dz2(x, b) = Application.IfError(Application.AverageIf(a1, ">=" & Application.IfError(Application.Large(a1, 3), 0), a1), 0)
        Next
        bas = a
        ay = Format(Cells(a, 1), "yyyy-mmmm")
    End If
Next
Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz1), UBound(dz1, 2)).Value = dz1

Set s1 = Sheets.Add(After:=Sheets(Sheets.Count))
s1.Range("A1").Resize(UBound(dz2), UBound(dz2, 2)).Value = dz2
End Sub
Genişletmek için tıkla ...

Size nasıl teşekkür edeceğimi bilemiyorum çok çok sağolun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst