Tarihe göre sayfalara yazsın

[mozdem]

Yazılan iki tarihin karşısındaki veriyi o tarihe ait Ay sayfasına veriyi yazdırmak istiyorum.
Ekteki Excel dosyasında ayrıntılı olarak açıkladım.Yardımlarınızı bekliyorum
Teşekkür ederim

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz? Ana Sayfada olmayan kişileri de ilgili sayfalara ekler.

Option Explicit
Option Base 1
Sub Doldur()
Dim Aylar As Variant, c As Variant, SyfAdi As Variant, ESyfAdi As Variant
Dim i As Long, SatirNo As Long
Dim j As Date
Dim Kolon As Integer
Dim sa As Worksheet
Set sa = Sheets("Ana Sayfa")
Aylar = Array("Ocak", "Şubat", "Mart", "Nisan", "Mayıs", "Haziran", "Temmuz", "Ağustos", "Eylül", "Ekim", "Kasım", "Aralık")
sa.Select
For i = 2 To [A65536].End(3).Row
    Kolon = 2
    ESyfAdi = ""
 
    Do
 
        For j = Cells(i, Kolon) To Cells(i, Kolon + 1)
 
            SyfAdi = Aylar(Month(j))
            If SyfAdi <> ESyfAdi Then
                ESyfAdi = SyfAdi
                Set c = Sheets(SyfAdi).Range("A:A").Find(Cells(i, "A"), LookIn:=xlValues)
                If Not c Is Nothing Then
                    SatirNo = c.Row
                Else
                    SatirNo = Sheets(SyfAdi).[A65536].End(3).Row + 1
                    Sheets(SyfAdi).Cells(SatirNo, "A") = Cells(i, "A")
                End If
            End If
 
            Sheets(SyfAdi).Cells(SatirNo, Day(j) + 1) = Cells(i, Kolon + 2)
        Next j
 
 
        Kolon = Kolon + 3
    Loop While Cells(i, Kolon) <> ""
 
Next i
MsgBox "Doldurma Tamamlanmıştır....", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Private Sub CommandButton1_Click()
Set s1 = Sheets("Ana Sayfa")
For Each sadi In Worksheets
    If sadi.Name <> "Ana Sayfa" Then
        Set s2 = Sheets(sadi.Name)
            s2.Range("b5:af50").ClearContents
        Set s2 = Nothing
    End If
Next
For i = 2 To s1.[a50].End(3).Row
    ad = s1.Cells(i, "a").Value
    For j = 2 To 17 Step 3
        If s1.Cells(i, j).Value <> "" Then
            For k = s1.Cells(i, j).Value To s1.Cells(i, j + 1).Value
                gün = Day(k)
                ay = Month(k)
                yil = Year(k)
                say = Application.WorksheetFunction.VLookup(ay, s1.[v2:w13], 2, False)
                Set s2 = Sheets(say)
                     With s2.Range("b4:af4")
                        Set Bul = .Find(gün, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not Bul Is Nothing Then ac = Bul.Column
                    End With
                    With s2.Range("a5:a50")
                        Set Bul = .Find(ad, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not Bul Is Nothing Then ar = Bul.Row
                    End With
                        s2.Cells(ar, ac).Value = s1.Cells(i, j + 2).Value
                    Set Bul = Nothing
                Set s2 = Nothing
            Next k
        End If
    Next j
Next i
Set s1 = Nothing
MsgBox "Düzenleme İşlemi Tamamlandı.", vbInformation, "Bilgi"
End Sub

 

[mozdem]

Necdet Yeşertener ve Recep ipek' e çok teşekür ediyorum.
Bu kadar hızlı cevap verdiğinizden ayrıca teşekürler.