7 bini geçen tutarlar

[igultekin2000]

iyi akşamlar;
listede " Tarih ve Tutar " durumuna göre ayın gün 7 bin TL' yi geçen ödemeler makro ile limit sayfasına aktarıyor. Tarihe göre tutarı alma özelliğine C sütunda olan firma ünvanınıda ilave etmek imkanı olabilir mi? Ayrıca aktarılan verilerin Ana Sayfa çalışma sayfasından da silinmesi mümkün olabilir mi? Teşekkürler.

Sub Aktar()
'17.12.2019   11:37
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual

c = MsgBox("Sayfa Güncellenecek" & Chr(10) & Chr(10) & "Onaylıyor musunuz?", vbOKCancel, "   Güncelleme Mesajı ")
If c = vbCancel Then Exit Sub
Range(Cells(2, 1), Cells(65500, 9)).ClearContents
 timer1 = Timer
 Do While Timer - timer1 < 0.3
 Loop
Cells(1, 1) = "Tarih"
sona = Sheets("Ana Sayfa").Cells(65500, 1).End(xlUp).Row
For i = 2 To sona
    topla = 0
    For j = 2 To sona
                If Sheets("Ana Sayfa").Cells(i, 1) = Sheets("Ana Sayfa").Cells(j, 1) Then
                topla = topla + Sheets("Ana Sayfa").Cells(j, 5)
                End If
        Next
    If topla >= 7000 Then
       sonaa = Cells(65500, 1).End(xlUp).Row + 1
        For p = 1 To 9
         Cells(sonaa, p) = Sheets("Ana Sayfa").Cells(i, p)
         Next
        End If
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic

End Sub

 

[EmrExcel16]

Firmalarin ayni gün içinde 7000 i geçenleri aktarmak istiyorsunuz doğrumudur , 2 kritere göre aktarilacak.

 

[igultekin2000]

Firmalarin ayni gün içinde 7000 i geçenleri aktarmak istiyorsunuz doğrumudur , 2 kritere göre aktarilacak.

evet, aynı gün 7000 TL' yi geçen listede farklı firmalar olduğunda firma sayısı 2' den fazla olacak. aktarımda tarih, firma ünvan ve tutar durumuna göre 7000' i geçen aktarım şeklinde.

 

[EmrExcel16]

Deneyiniz.

Sub Emr_Aktar()

    Dim s1, i, SonSat, Aktarim
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set s1 = Sheets("Ana Sayfa")

    s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).FormulaR1C1 = "=SUMIFS(C[-5],C[-9],RC[-9],C[-7],RC[-7])"
    s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).Value = s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).Value

    SonSat = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Aktarim = 0
    
    For i = s1.Cells(s1.Rows.Count, 3).End(3).Row To 2 Step -1
        If s1.Cells(i, 10) > 7000 Then
            Range(Cells(SonSat, 1), Cells(SonSat, 10)).Value = Range(s1.Cells(i, 1), s1.Cells(i, 10)).Value
            Range(s1.Cells(i, 1), s1.Cells(i, 10)).Delete (xlUp)
            SonSat = SonSat + 1
            Aktarim = Aktarim + 1
        End If
    Next
    
    s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).ClearContents
    Range(Cells(2, 10), Cells(Cells(Rows.Count, 3).End(3).Row, 10)).ClearContents
    
    MsgBox Aktarim & " Aktarim islemi basariyla tamamlandi"
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
  
End Sub

 

[igultekin2000]

Deneyiniz.

Sub Emr_Aktar()

    Dim s1, i, SonSat, Aktarim
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set s1 = Sheets("Ana Sayfa")

    s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).FormulaR1C1 = "=SUMIFS(C[-5],C[-9],RC[-9],C[-7],RC[-7])"
    s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).Value = s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).Value

    SonSat = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Aktarim = 0
   
    For i = s1.Cells(s1.Rows.Count, 3).End(3).Row To 2 Step -1
        If s1.Cells(i, 10) > 7000 Then
            Range(Cells(SonSat, 1), Cells(SonSat, 10)).Value = Range(s1.Cells(i, 1), s1.Cells(i, 10)).Value
            Range(s1.Cells(i, 1), s1.Cells(i, 10)).Delete (xlUp)
            SonSat = SonSat + 1
            Aktarim = Aktarim + 1
        End If
    Next
   
    s1.Range(s1.Cells(2, 10), s1.Cells(s1.Cells(s1.Rows.Count, 3).End(3).Row, 10)).ClearContents
    Range(Cells(2, 10), Cells(Cells(Rows.Count, 3).End(3).Row, 10)).ClearContents
   
    MsgBox Aktarim & " Aktarim islemi basariyla tamamlandi"
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 
End Sub

Teşekkür ederim, sorunsuz çalışıyor, elinize sağlık, iyi çalışmalar

 

[EmrExcel16]

Teşekkür ederim, sorunsuz çalışıyor, elinize sağlık, iyi çalışmalar

Rica ederim , iyi çalışmalar.