Dönem aralığı için tablolama

[sercio_sercio]

Selamlar,

Ben bir makro yazmak istiyorum, Örneğin Temmuz-Aralık dönem aralığında 6 aya ait değerlerin dört şirket için her ay kendi sütununda olacak şekilde bir tabloda toplamam gerekiyor. Tek bir ay olduğu zaman problem değil bu aya ait değerleri getirip sort edebiliyorum. Ancak belirli bir dönem aralığı verildiğinde bu dönemleri nasıl ayırt ettirebilirim. Ekte daha açıklamalı olması açısından bir örnek excel mevcuttur.

Yardımlarınızı rica ediyorum.

Teşekkürler

 

[Ömer]

Merhaba,

Sayfa boyunca farklı bölgelerde seçim yaparak mı rapor alacaksınız yoksa tek bir seçimle mi rapor alacaksınız.

Tek sayfanın farklı bölümlerinde seçim yaparak uygulama yapacaksanız tablolama için iyi bir yöntem olmayacaktır.

 

[bmutlu966]

İstediğiniz bilgileri Pivot kullanarak Data sayfasından alabilirsiniz.

 

[sercio_sercio]

Ömer Selam,

Tablolar sayfanın aynı bölgesinde kalacak şekilde düzenleyeceğim dolayısıyla hep standart bir düzen olacak.

 

[Ömer]

Ömer Selam,

Tablolar sayfanın aynı bölgesinde kalacak şekilde düzenleyeceğim dolayısıyla hep standart bir düzen olacak.

Modul il satıra:

Option Compare Text

İlk aralık için:

Sub Ilk_Secim()
 
    Dim Sd As Worksheet, i As Byte, j As Byte, c As Range
    Dim Adr As String, sat As Byte
 
    Set Sd = Sheets("Data")
    Sheets("Tablo").Select
    Range(Cells(6, 2), Cells(10, Columns.Count)).ClearContents
 
    For i = Month(CDate("1." & [B2])) To Month(CDate("1." & [C2]))
        Cells(6, sat + 2) = Format(CDate("1." & i), "mmmm")
        sat = sat + 1
    Next i
    For i = 7 To 10
        With Sd.Range("A:A")
            Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    For j = 2 To Cells(6, Columns.Count).End(xlToLeft).Column
                        If .Cells(c.Row, "B") = Cells(6, j) Then
                            Cells(i, j) = .Cells(c.Row, "C")
                        End If
                    Next j
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
End Sub

İkinci aralık için:

Sub Ikinci_Secim()
 
    Dim Sd As Worksheet, i As Byte, j As Byte, c As Range
    Dim Adr As String, sat As Byte
 
    Set Sd = Sheets("Data")
    Sheets("Tablo").Select
    Range(Cells(16, 2), Cells(20, Columns.Count)).ClearContents
 
    For i = Month(CDate("1." & [B13])) To Month(CDate("1." & [C13]))
        Cells(16, sat + 2) = Format(CDate("1." & i), "mmmm")
        sat = sat + 1
    Next i
    For i = 17 To 20
        With Sd.Range("A:A")
            Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    For j = 2 To Cells(16, Columns.Count).End(xlToLeft).Column
                        If .Cells(c.Row, "B") = Cells(16, j) Then
                            Cells(i, j) = .Cells(c.Row, "C")
                        End If
                    Next j
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
End Sub

 

[sercio_sercio]

Ömer Hocam eline sağlık makro harika çalışıyor Bir de sorum olacak izninle.
Şu satırın amacı nedir? "Option Compare Text"

Teşekkürler

 

[Ömer]

Arama yaparken büyük küçük harf ayırımı yapmadan arar.

Dikkat ederseniz ay isimleri data sayfasında küçük harfle başlıyor. Tablo sayfasında ise makro bu isimleri büyük yazıyor. Bu yüzden o satırı kullandım.

Yalnız İ, ı gibi harflere duyarlı değildir. Ay isimlerinde baş hafler İ,ı olmadığı için sizin dosyada bir sorun teşkil etmeden çalışır.

Bu olayı aşmak için farklı yöntemlerde kullanılır. Aklıma ilk gelen bu olduğu için bu şekilde yazdım.

 

[sercio_sercio]

Hücredeki tarihe göre raporlama

Selamlar arkadaşlar Ömerin de yardımlarıyla tablolama makromun büyük kısmını hallettim ama ufak bişey kaldı nasıl yapacağımı bilmiyorum

Ekteki örnekte de görebileceğiniz gibi başlangıç ayını B4'den bitiş ayını C4'ten alıyor ancak makroyu sadece bir aylık çalıştırmak istediğim zaman her iki hücrenin de dolu olması gerekiyor örneğin şubat - şubat gibi. Ancak tek ay raporlama yapacağım için bu hücrelerden sadece biri dolu olması yeterli aslında. Burada nasıl bir düzenleme yapmam gerekiyor yardımcı olabilir misiniz?

 

[Ömer]

Ancak tek ay raporlama yapacağım için bu hücrelerden sadece biri dolu olması yeterli aslında. Burada nasıl bir düzenleme yapmam gerekiyor yardımcı olabilir misiniz?

Bu şekilde deneyin.

Option Compare Text
 
Sub Ilk_Secim()
 
    Dim Sd As Worksheet, i As Byte, j As Byte, c As Range
    Dim Adr As String, sat As Byte
    
    If [B4] <> "" And [C4] <> "" Then
        If Month(CDate("1." & [B4])) > Month(CDate("1." & [C4])) Then MsgBox _
            "Başlangıç Tarihi Bitiş Tarihinden Büyük Olamaz...": Exit Sub Else
    End If
            
    Application.ScreenUpdating = False
    Sheets("RadyoRawData").Select
    Columns("A:D").AutoFilter
    ActiveSheet.Range("A:D").AutoFilter Field:=4, Criteria1:=Sheets("Radyo Erişim").Range("B3").Value
 
 
    Set Sd = Sheets("RadyoRawData")
    Sheets("Radyo Erişim").Select
    Range(Cells(6, 5), Cells(34, Columns.Count)).ClearContents
 
    If [B4] <> "" Then [E6] = [B4] Else [E6] = [C4]
    For i = Month(CDate("1." & [B4])) To Month(CDate("1." & [C4]))
        If [B4] = "" Or [C4] = "" Then
            If [B4] <> "" Then [E6] = [B4] Else [E6] = [C4]
            Exit For
        End If
        Cells(6, sat + 5) = Format(CDate("1." & i), "mmmm")
        sat = sat + 1
    Next i
    For i = 7 To 34
        With Sd.Range("A:A")
            Set c = .Find(Cells(i, "D"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    For j = 2 To Cells(6, Columns.Count).End(xlToLeft).Column
                        If .Cells(c.Row, "B") = Cells(6, j) Then
                            Cells(i, j) = .Cells(c.Row, "C")
                        End If
                    Next j
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    Application.ScreenUpdating = True
End Sub

.

 

[sercio_sercio]

Ömer yardımın için teşekkürler