Tarihe göre ay olarak belirtilen sayfalara ilgili satırları aktarma

[kaptan38]

Merhaba arkadaşlar. öncelikli olarak bu siteyi ziyaret ederk gerçekten çok şey öğrendiğimi belirtmek isterim. Burada bilgi paylaşan herkese çok teşekkür ederim. Herkesin emeğine sağlık. Soruma gelince ekteki tabloda örneklediğim gibi ana sayfadaki bu verileri, her bir satırın kendi tarihine göre ilgili aya ait sayfaya tarih sıralı olarak aktarılması gerekli. Bütün konuları inceledim ama ne yaptıysam olmadı. Makro bilgim çok kısıstlı olduğu için sadece kullanılan kodları ufak tefek değiştirmeye çalıştım ama olmadı. Yardımcı olabilirseniz seviinirim. şimdiden çok teşekkür ederim.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Sayfalara_Dagit()
 
    Dim syf As String, i As Long, j As Long
 
    Application.ScreenUpdating = False
    Sheets("2011 SEVKİYAT").Select
 
    On Error Resume Next
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        syf = Format(Cells(i, "A"), "mmmm")
        With Sheets(syf)
            j = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range("A" & i, "H" & i).Copy .Cells(j, "A")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[kaptan38]

merhaba,

bu şekilde deneyin.

sub sayfalara_dagit()
 
    dim syf as string, i as long, j as long
 
    application.screenupdating = false
    sheets("2011 sevkiyat").select
 
    on error resume next
    for i = 3 to cells(rows.count, "a").end(xlup).row
        syf = format(cells(i, "a"), "mmmm")
        with sheets(syf)
            j = .cells(rows.count, "a").end(xlup).row + 1
            range("a" & i, "h" & i).copy .cells(j, "a")
        end with
    next i
 
    msgbox "aktarım tamamlandı.", , "excel.web.tr"
 
    application.screenupdating = true
 
end sub

.

çok teşekkür ederim ellerinize sağlık ama bunu her yazdığımda kaydetmem gerekiyor ve bir satırı yanlış yazdığımda ana sayfadan silme işlemi yapınca ilgili sayfadaki değer silinmiyor. Bunu nasıl halledebilirim acaba.

 

[kaptan38]

Ve her aktarma işleminde önceki aktardığı verileri tekrar aynı sayfaların altına aktarıyor. Anlamadım ki ben

 

[Vedat Özer]

Merhabalar,


Ömer hocama vermiş oldugu kodlar için teşekkür ederim.

Koda ekleme yaptım.

Koyu renkli yerdir.

Sub Sayfalara_Dagit()
 
    Dim syf As String, i As Long, j As Long
 
    Application.ScreenUpdating = False
    Sheets("2011 SEVKİYAT").Select
 
    On Error Resume Next
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        syf = Format(Cells(i, "A"), "mmmm")
        With Sheets(syf)
            [B]j = .Range("A3:H" & Rows.Count).ClearContents[/B]
            j = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range("A" & i, "H" & i).Copy .Cells(j, "A")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
    Application.ScreenUpdating = True
 
End Sub

 

[kaptan38]

Merhabalar,


Ömer hocama vermiş oldugu kodlar için teşekkür ederim.

Koda ekleme yaptım.

Koyu renkli yerdir.

Sub Sayfalara_Dagit()
 
    Dim syf As String, i As Long, j As Long
 
    Application.ScreenUpdating = False
    Sheets("2011 SEVKİYAT").Select
 
    On Error Resume Next
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        syf = Format(Cells(i, "A"), "mmmm")
        With Sheets(syf)
            [B]j = .Range("A3:H" & Rows.Count).ClearContents[/B]
            j = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range("A" & i, "H" & i).Copy .Cells(j, "A")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
    Application.ScreenUpdating = True
 
End Sub

hocam emeğinize sağlık. ancak bu kodu kullandığım zaman mesela ocak ayındaki en son işlediğim satırı ilgili sayfaya kopyalıyor. diğerlerini eklemiyor.

 

[Ömer]

Bu şekilde deneyin.

Sub Sayfalara_Dagit()
 
    Dim syf As String, i As Long, j As Long
 
    Application.ScreenUpdating = False
    Sheets("2011 SEVKİYAT").Select
 
    On Error Resume Next
    
    For i = 1 To Worksheets.Count
        With Sheets(i)
            If .Name <> "2011 SEVKİYAT" Then
                .Range("A3:H" & Rows.Count).ClearContents
            End If
        End With
    Next i
    
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        syf = Format(Cells(i, "A"), "mmmm")
        With Sheets(syf)
            j = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range("A" & i, "H" & i).Copy .Cells(j, "A")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[kaptan38]

Hocam emeğinize sağlık. çok teşekkür ederim tam istediğim gibi olmuş. Ellerinize sağlık.