makroya tarih ekleme

[igultekin2000]

http://s3.dosya.tc/server10/5ig033/Kumas_IML_v1.01_-_Kopya.rar.html

iyi akşamlar; envanter sayfasında oluşan değerlerde çoketoplama yaptırıyorum ancak bu çoketoplaya tarih sınırlaması eklemek istiyorum. yardımcı olacak arkadaşlara teşekür ederim.

Sub KOD()
    Application.ScreenUpdating = False
    Dim SV As Worksheet: Set SV = Sheets("Envanter")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
    
    ST.Range("A3:E" & Rows.Count).ClearContents 'çoketoplanın yapılacağı yer
    sat = 3
    For i = 3 To SV.Cells(Rows.Count, "D").End(3).Row 'baz alınacak değer
        If WorksheetFunction.CountIf(SV.Range("D3:D" & i), SV.Cells(i, "D")) = 1 Then
ST.Cells(sat, "B") = SV.Cells(i, "D")
ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("E:E"))
ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("G:G"))
ST.Cells(sat, "E") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("H:H"))
ST.Cells(sat, "F") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("K:K"))
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

 

[vardar07]

Karşılaştırınız.

Sub KOD()
[COLOR="Red"]Dim a As Date[/COLOR] 'yeni
    Application.ScreenUpdating = False
    Dim SV As Worksheet: Set SV = Sheets("Envanter")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
    
    ST.Range("A3:F" & Rows.Count).ClearContents 'çoketoplanın yapılacağı yer
    sat = 3
    For i = 3 To SV.Cells(Rows.Count, "D").End(3).Row 'baz alınacak değer
       [COLOR="red"]a = SV.Cells(i, "B")[/COLOR] 'yeni
        [COLOR="red"]If WorksheetFunction.CountIf(SV.Range("D3:D" & i), SV.Cells(i, "D")) = 1 _
        And a >= ST.Cells(1, "E") And a <= ST.Cells(1, "F") Then [/COLOR]'yeni
ST.Cells(sat, "B") = SV.Cells(i, "D")
ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("E:E"))
ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("G:G"))
ST.Cells(sat, "E") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("H:H"))
ST.Cells(sat, "F") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("K:K"))
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

 

[igultekin2000]

sorunsuz çalışıyor

Karşılaştırınız.

Sub KOD()
[COLOR="Red"]Dim a As Date[/COLOR] 'yeni
    Application.ScreenUpdating = False
    Dim SV As Worksheet: Set SV = Sheets("Envanter")
    Dim ST As Worksheet: Set ST = Sheets("Tablo")
    
    ST.Range("A3:F" & Rows.Count).ClearContents 'çoketoplanın yapılacağı yer
    sat = 3
    For i = 3 To SV.Cells(Rows.Count, "D").End(3).Row 'baz alınacak değer
       [COLOR="red"]a = SV.Cells(i, "B")[/COLOR] 'yeni
        [COLOR="red"]If WorksheetFunction.CountIf(SV.Range("D3:D" & i), SV.Cells(i, "D")) = 1 _
        And a >= ST.Cells(1, "E") And a <= ST.Cells(1, "F") Then [/COLOR]'yeni
ST.Cells(sat, "B") = SV.Cells(i, "D")
ST.Cells(sat, "C") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("E:E"))
ST.Cells(sat, "D") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("G:G"))
ST.Cells(sat, "E") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("H:H"))
ST.Cells(sat, "F") = WorksheetFunction.SumIf(SV.Range("D:D"), SV.Cells(i, "D"), SV.Range("K:K"))
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

bu haliyle sorunsuz çalışor, teşekkürler