Aylar itibariyle maksimum puanları yazdırma

Gamma · 19 Temmuz 2024

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.

Tevfik_Kursun · 19 Temmuz 2024

Merhaba,
Gerçek dosyanızla birebir aynı olan örnek bir dosya eklerseniz istediğiniz herhangi bir yöntem ile çözüm üretilebilir

ÖmerBey · 19 Temmuz 2024

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

Gamma · 19 Temmuz 2024

Ö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

çok teşekkür ederim hemen deniyorum

Gamma · 19 Temmuz 2024

Ö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

Çok çok teşekkürler harika çalıştı

Gamma · 19 Temmuz 2024

Ö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

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.

ÖmerBey · 19 Temmuz 2024

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

Gamma · 19 Temmuz 2024

Ö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

Çok çok teşekkür ederim

ÖmerBey · 19 Temmuz 2024

Rica ederim,
İyi çalışmalar...

Gamma · 19 Temmuz 2024

Ö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.

ÖmerBey · 19 Temmuz 2024

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.

Gamma · 19 Temmuz 2024

Ö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.

Ç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

ÖmerBey · 19 Temmuz 2024

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

Gamma · 19 Temmuz 2024

Ö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

Size nasıl teşekkür edeceğimi bilemiyorum çok çok sağolun

Aylar itibariyle maksimum puanları yazdırma

Gamma

Tevfik_Kursun

ÖmerBey

Destek Ekibi

Gamma

Gamma

Gamma

ÖmerBey

Destek Ekibi

Gamma

ÖmerBey

Destek Ekibi

Gamma

ÖmerBey

Destek Ekibi

Gamma

ÖmerBey

Destek Ekibi

Gamma