Sayıları Aylara Göre Almak

[1Al2Ver]

Merhaba,

"A2:L1250" arası makro ile alınmaktadır.

Ben, "O2:Z12" aralığını, "A2:L1250" aralığından formüllerle alıyorum.

İsteğim ; "O2:Z12" aralığını, makro ile almak.

Teşekkür ederim.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[1Al2Ver]

Sayın muygun, merhaba,

Çözüm ve ilginiz için teşekkür ederim.

Saygılarımla.

 

[Muzaffer Ali]

Merhaba.
Bu kodlar da alternatif olsun

Sub Test()
    Dim Say As Long
    Dim Bak As Range
    Dim Sehir As Integer
    Dim Kolon As Integer
    Dim Ay As Integer
    Range("O2:Z11").ClearContents
    Say = Cells(Rows.Count, "A").End(3).Row
    For Sehir = 2 To 11
        Kolon = WorksheetFunction.Match(Range("N" & Sehir).Text, Range("B1:K1"), 0)
        For Ay = 1 To 12
            For Each Bak In Range("A2:A" & Say)
                If Month(Bak.Value) = Ay Then
                    Cells(Sehir, Ay + 14).Value = Cells(Sehir, Ay + 14).Value + Bak(1, Kolon + 1).Value
                End If
            Next
            Cells(12, Ay + 14).Value = WorksheetFunction.Sum(Range(Cells(2, Ay + 14).Address & ":" & Cells(11, Ay + 14).Address))
        Next
        Cells(Sehir, Ay + 14).Value = WorksheetFunction.Sum(Range("O" & Sehir & ":Z" & Sehir))
        Cells(Sehir, Ay + 15).Value = WorksheetFunction.AverageIf(Range("O" & Sehir & ":Z" & Sehir), ">0")
        Cells(12, Ay + 14).Value = WorksheetFunction.Sum(Range(Cells(2, Ay + 14).Address & ":" & Cells(11, Ay + 14).Address))
    Next
    MsgBox "İşlem tamamlandı.."
End Sub

 

[1Al2Ver]

Sayın dalgalıkur, merhaba,

Alternatif kod ve duyarlığınız için teşekkür ederim.

Saygılarımla.

 

[Ziynettin]

Bende çalışma yapmıştım. Alternatif olsun.

Sub sayilar()
Sheets("SAYILAR").Select
yil = [AA1]
Set d = CreateObject("scripting.dictionary")
a = Range("A1:K" & Cells(Rows.Count, 1).End(3).Row)
yil = [AA1]
    For i = 2 To UBound(a)
        If yil = Year(a(i, 1)) Then
            ay = UCase(Replace(Replace(Format("1." & Month(a(i, 1)), "mmmm"), "i", "İ"), "ı", "I"))
            For j = 2 To UBound(a, 2)
                krt = ay & "|" & a(1, j)
                d(krt) = d(krt) + a(i, j)
            Next j
        End If
    Next i
b = [N1:Z11]
    If d.Count > 0 Then
        ReDim c(1 To UBound(b), 1 To UBound(b, 2) + 1)
        For i = 2 To UBound(b)
            For j = 2 To UBound(b, 2)
                krt = b(1, j) & "|" & b(i, 1)
                c(i - 1, j - 1) = d(krt)
                c(UBound(b), j - 1) = c(UBound(b), j - 1) + d(krt)
                t = t + d(krt)
                If d(krt) <> "" Then n = n + 1
            Next j
            c(i - 1, UBound(b, 2)) = t
            c(i - 1, UBound(b, 2) + 1) = t / n
            c(UBound(b), UBound(b, 2)) = c(UBound(b), UBound(b, 2)) + t
            c(UBound(b), UBound(b, 2) + 1) = c(UBound(b), UBound(b, 2) + 1) + t / n
            t = 0
            n = 0
        Next i
        [O2].Resize(UBound(b), UBound(b, 2) + 1) = c
        MsgBox "İşlem tamam.", vbInformation
    Else
        [O2].Resize(UBound(b), UBound(b, 2) + 1) = ""
        MsgBox "Sonuç bulunamadı.", vbCritical
    End If
End Sub

 

[1Al2Ver]

Sayın Ziynettin, merhaba,

Alternatif kod ve ilginiz için teşekkür ederim,

Saygılarımla.