Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 19-05-2017, 21:43   #1
hexadesimal
Destek Ekibi
 
hexadesimal kullanıcısının avatarı
 
Giriş: 12/09/2004
Şehir: İZMİR
Mesaj: 668
Excel Vers. ve Dili:
Excel 2010 Türkçe (Her Zaman)
Varsayılan Aylık okuma rapor

Sınıf kitaplık uygulaması yapmaya çalışıyorum. Soruna ilişkin açıklama ekli çalışma kitabının OKUMA adlı sayfasında mevcut. İlgileneceklere şimdiden teşekkürler.
Eklenmiş Dosyalar
Dosya Türü: xlsm Çalışma2.xlsm (47.0 KB, 10 Görüntülenme)
__________________
Excel 2003
Müzmin KEMALİST
hexadesimal Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-05-2017, 00:33   #2
Korhan Ayhan
Moderatör
 
Korhan Ayhan kullanıcısının avatarı
 
Giriş: 15/03/2005
Şehir: ANTALYA
Mesaj: 21,893
Excel Vers. ve Dili:
OFFICE 2013-2016 PRO TR
Varsayılan

Aşağıdaki kodu deneyiniz.

Kendinize uyarlarsınız.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet, WF As WorksheetFunction
    Dim Son As Long, Satir As Long, X As Long, Bul As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("OKUMA")
    Set S2 = Sheets("AY_RAPOR")
    Set WF = WorksheetFunction
    
    S2.Range("A4:P" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 4
    
    For X = 2 To Son
        If S1.Cells(X, 2) <> "" Then
            If WF.CountIf(S2.Range("C:C"), S1.Cells(X, 2)) = 0 Then
                S2.Cells(Satir, 1) = Satir - 3
                S2.Cells(Satir, 3) = S1.Cells(X, 2)
                For Y = 4 To 15
                    If Month(S1.Cells(X, 7)) = Y - 3 Then
                        S2.Cells(Satir, Y) = S2.Cells(Satir, Y) + S1.Cells(X, 4)
                    End If
                Next
                S2.Cells(Satir, 16) = WF.Sum(S2.Range("D" & Satir & ":O" & Satir))
                Satir = Satir + 1
            Else
                Set Bul = S2.Range("C:C").Find(S1.Cells(X, 2), , , xlWhole)
                If Not Bul Is Nothing Then
                    For Y = 4 To 15
                        If Month(S1.Cells(X, 7)) = Y - 3 Then
                            S2.Cells(Bul.Row, Y) = S2.Cells(Bul.Row, Y) + S1.Cells(X, 4)
                        End If
                    Next
                    S2.Cells(Bul.Row, 16) = WF.Sum(S2.Range("D" & Bul.Row & ":O" & Bul.Row))
                End If
            End If
        End If
    Next

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
__________________
.
.
.

Soru sormadan önce forumumuzun aşağıdaki
bölümlerini incelediğinizde birçok sorunuza yanıt bulabilirsiniz.


Excel Dersanesi
Uygulamalı Excel Eğitimi
Excel İçin Örnek Uygulamalar
Video Dersane (***Altın Üyelere Özel***)

Lütfen sorularınızın çözümlendiğine dair geri dönüş mesajı yazınız...!
Lütfen yazım ve forum kurallarına uyalım...!
Lütfen sorularımızı açık ve net bir dille ifade edelim...!



FORUM KURALLARI
Korhan Ayhan Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-05-2017, 00:44   #3
Ziynettin
Altın Üye
 
Giriş: 17/04/2008
Şehir: istanbul
Mesaj: 327
Excel Vers. ve Dili:
office2010
Varsayılan

Bende yazmıştım alternatif olsun

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub tablo()
Set s1 = Sheets("OKUMA")
Set s2 = Sheets("AY_RAPOR")
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
a = s1.Range("B2:G" & s1.Range("A" & Rows.Count).End(3).Row)
    For i = 1 To UBound(a)
        ad = UCase(Replace(Replace(a(i, 1), "i", "İ"), "ı", "I"))
        ay = UCase(Replace(Replace(Format(a(i, 6), "mmmm"), "i", "İ"), "ı", "I"))
        krt = ad & "|" & ay
        If Not IsEmpty(a(i, 1)) Then
            d1(ad) = ""
            d(krt) = d(krt) + a(i, 3) * 1
        End If
    Next i
s2.Range("C4:P" & Rows.Count).ClearContents
s2.[C4].Resize(d1.Count) = Application.Transpose(d1.keys)
c = s2.[C4].Resize(d1.Count).Value
e = s2.[D3:O3]
ReDim v(1 To UBound(c), 1 To UBound(e, 2))
    For i = 1 To UBound(c)
        For X = 1 To UBound(e, 2)
            v(i, X) = (d(c(i, 1) & "|" & e(1, X)))
        Next X
    Next i
s2.[D4].Resize(d1.Count, UBound(e, 2)) = v
ReDim t(1 To d1.Count, 1 To 1)
    For i = 1 To d.Count
        t(i, 1) = Application.Sum(Application.Index(v, i))
    Next i
s2.[P4].Resize(d1.Count) = t
MsgBox "İşleminiz tamamlandı.....", vbInformation
End Sub
Ziynettin Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-05-2017, 09:12   #4
hexadesimal
Destek Ekibi
 
hexadesimal kullanıcısının avatarı
 
Giriş: 12/09/2004
Şehir: İZMİR
Mesaj: 668
Excel Vers. ve Dili:
Excel 2010 Türkçe (Her Zaman)
Varsayılan

Sayın Korhan AYHAN ve Ziynettin teşekkürler.
__________________
Excel 2003
Müzmin KEMALİST
hexadesimal Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 09:45


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - Investing - Hurda - Tekirdağ Samsung - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu osgb - Lingerie - Dyeing Machine - Çorlu Temizlik- Çorlu Ambar- Hava Çekimi- Hazır Site- SEO- Çorlu Burun Estetiği- Çorlu Pimapen- Karton Bardak- Marka Tescil Danışmanlık- Marmara Ereğlisi Restaurant- Çorlu Baskı- Çorlu Sigorta- Çorlu Pimapenci- İstanbul Avukat-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden