Kritere Göre Verileri Başka Tabloya Otomatik Aktarma

[emnozdemir]

Selamlar !
Ekli dosyadaki soldaki verileri, ödeme takip tablosuna (sarı renli alanlara) Ödeme ay'ına göre, (sarı renkli alandaki verilerin tümünü) otomatik aktarmak mümkünmüdür acaba? Yardımcı olursanız sevinirim.
Şimdiden Teşekkürler.

 

[İhsan Tank]

Selamlar !
Ekli dosyadaki soldaki verileri, ödeme takip tablosuna (sarı renli alanlara) Ödeme ay'ına göre, (sarı renkli alandaki verilerin tümünü) otomatik aktarmak mümkünmüdür acaba? Yardımcı olursanız sevinirim.
Şimdiden Teşekkürler.

eki inceler misiniz
sarı boyalı alanladaki formüller dizi formülüdür

Dizi Formülü Formül Hücreye Girildikten Sonra Enter Tuşuna Basmadan Ctrl+Shift+Enter Tuş Kombinasyonu İle Aktif Olmaktadır. Formülün Başında Ve Sonunda { } Bu İşaretler Çıkar Elle Eklediğiniz Takdirde Formül Hata Verir.

formülde 1000 satır baz alınmıştır. formülü yeterince aşağıya doğru çekiniz
Yeşile boyadığım yerdeki hücre biçimlendirmeyi ve girdiğim veriyi kontrol ediniz.

 

[excel03]

merhaba;

Sub OdemeAktar()
Dim alan As Range
Dim DT As Date
sonsatE = Cells(65536, "E").End(3).Row
Set alan = Range("e2:e" & sonsatE)
    For i = 1 To alan.Cells.Count
    DT = alan.Cells(i)
    m = Month(DT) Mod 2
    
        If m = 0 Then
        sonsatM = Cells(65536, "M").End(3).Row + 1
        Range(alan.Cells(i).Offset(0, 0), alan.Cells(i).Offset(0, -4)).Copy Range("M" & sonsatM)
        End If
        
        If m = 1 Then
        sonsatG = Cells(65536, "G").End(3).Row + 1
        Range(alan.Cells(i).Offset(0, 0), alan.Cells(i).Offset(0, -4)).Copy Range("G" & sonsatG)
        End If
    
    Next
End Sub

 

[emnozdemir]

İlginize Teşekkür ediyorum

 

[İhsan Tank]

İlginize Teşekkür ediyorum

rica ederim
iyi çalışmalar :mutlu:

 

[usubaykan]

Merhaba;

Bir alternatifte benden olsun

Option Explicit
Sub DENEME()
Dim U As Long, DEĞER As String, BUL As Range, ADRES As String, Son_Satır As Long
Range("G3:Q65536").ClearContents
    For U = 2 To Range("E65536").End(3).Row
        DEĞER = Format(Cells(U, "E"), "MMMM") & " " & Year(Cells(U, "E")) & " ÖDEMELERİ"
        Set BUL = Cells.Find(DEĞER)
 
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                Son_Satır = Cells(65536, BUL.Column).End(3).Row + 1
                Cells(Son_Satır, BUL.Column) = Cells(U, "A")
                Cells(Son_Satır, BUL.Column + 1) = Cells(U, "B")
                Cells(Son_Satır, BUL.Column + 2) = CCur(Cells(U, "C"))
                Cells(Son_Satır, BUL.Column + 3) = CDate(Cells(U, "D"))
                Cells(Son_Satır, BUL.Column + 4) = CDate(Cells(U, "E"))
                BUL = Cells.FindNext(BUL)
            Loop While Not BUL Is Nothing And ADRES <> BUL.Address
        End If
    Next
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "Sn: " & Application.UserName
End Sub

Kullandığınız 2. Satırdaki başlıklara göre hareket etmektedir. Örneğin "OCAK 2011 ÖDEMELERİ" yazan satırın altına uyan verileri sıralamaktadır. "MART 2011 ÖDEMELERİ" olarak bir satır eklediğinizde mart ayı ile ilgili verileri listeyecektir.

 

[emnozdemir]

Peki ekli dosyadaki gibi, Ay Toplamı alarak Aşağıya doğru sıralayarak tamamını otomatik aktarmak mümkünmüdür acaba?

 

[emnozdemir]

Üstteki mesajımı inceleyen var mı acaba?

 

[usubaykan]

Merhaba;
Aşağıdaki kodu uygulayınız.

Option Explicit
Sub DENEME()
Dim U As Long, S As Long, Son_Satır As Long, TOPLA As Double
Range("G2:K65536").Font.Bold = False
Range("G2:K65536").ClearContents
Range("A2:E" & Range("E65536").End(3).Row).Copy
Range("G2:K2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("G2:K7").Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Son_Satır = Cells(65536, "H").End(3).Row
Cells(Son_Satır + 1, "H") = Format(Cells(Son_Satır, "K"), "MMMM YYYY") & " ÖDEMELERİ"
For U = Range("K65536").End(3).Row To 3 Step -1
If Format(Cells(U, "K"), "MMMM YYYY") <> Format(Cells(U - 1, "K"), "MMMM YYYY") Then
Range("G" & U & ":K" & U).Insert Shift:=xlDown
Cells(U, "H") = Format(Cells(U - 1, "K"), "MMMM YYYY") & " ÖDEMELERİ"
End If
Next
For S = 2 To Range("H65536").End(3).Row
If Cells(S, "I") <> "" Then
TOPLA = TOPLA + Cells(S, "I")
Else
If Cells(S, "I") = "" Then
Cells(S, "I") = TOPLA
Range(Cells(S, "H"), Cells(S, "I")).Font.Bold = True
TOPLA = 0
End If
End If
Next
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "Sn: " & Application.UserName
End Sub

 

[emnozdemir]

Teşekkür ederim