Tarihe göre veri saydırmak

[omeryılmaz]

Merhaba Arkadaşlar..

Kurumumuzca yapılan denetimler sonucu Ay sonu istatistik çalışmalarda kullandığım çalışmama Formdan yararlanarak verileri saydırmak üzere Makro ile bir çalışma yaptım ancak takıldım.

Sorum

İşletmeye ait İhlalleri (var) yazanları "H" sütununa Say
Tarihe göre İhlal sonrası yapılan denetimleri de "I" sütununa saydırmak istedim ancak bir türlü makroya uyarlayamadım..


Örnek Dosya ilişikte sunulmuş olup, Yardımlarınız için şimdiden şükranlarımı sunuyorum.. Saygılar

 

[Necdet]

Merhaba,

"Tarihe Göre" den kastınızı nedir, bunu açmanız gerekir.

 

[omeryılmaz]

Merhaba,

"Tarihe Göre" den kastınızı nedir, bunu açmanız gerekir.

İhlal tarihinden itibaren işletmenin en az üç defa denetlenip denetlenmediğini saydırmak için


Dosyada Ömer YILMAZ ait işletme 9.5.2011 tarihindeki ihlalden sonra 22.5.2013 tarihine kadar 5 defa denetlenmiş

Ancak aynı işletme 24.5.2013 tarihinde ikinci ihlal sonrası bir defa denetlenmiş

Aynı İşletmeye ait İlk Tarihli İhlal (Var) =1 İkinci İhlal(Var) =2
Yok yazanlarda İhlaller arası denetim sayısı...

İlginiz için şükranlarımı sunuyorum...

 

[apocalyt]

Meraba.. ilk düğme için

Private Sub CommandButton1_Click()
Dim i As Long, son As Long
Application.ScreenUpdating = False
Range("H2:H65000").ClearContents
For x = 2 To Cells(65536, "F").End(xlUp).Row
srangea = Range("d2:d" & x).Address
srangeb = Range("h2:h" & x).Address
If Cells(x, "f") = "Var" Then
Cells(x, "h") = 1 + Evaluate("=sumproduct((" & srangea & "=""" & Cells(x, "d") & """)*(" & srangeb & "<>""" & "" & """))")
End If
Next x
End Sub
ikinci düğme için

Private Sub CommandButton2_Click()
Dim i As Long, son As Long
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
s1.Range("I2:I65000").ClearContents
a = 1
For x = 2 To s1.Cells(65536, "F").End(xlUp).Row
If Cells(x, "f") = "Yok" And Cells(x, "ı") = "" Then
Cells(x, "ı") = a
a = a + 1
For y = x + 1 To s1.Cells(65536, "F").End(xlUp).Row
If Cells(x, "d") = Cells(y, "d") And Cells(y, "f") = "Yok" Then
Cells(y, "ı") = a
a = a + 1
ElseIf Cells(y, "d") = Cells(x, "d") Then Exit For
End If
Next y
Else
a = 1
End If
a = 1
Next x
Application.ScreenUpdating = True
End Sub
denermisiniz.

 

[omeryılmaz]

Meraba.. ilk düğme için

Private Sub CommandButton1_Click()
Dim i As Long, son As Long
Application.ScreenUpdating = False
Range("H2:H65000").ClearContents
For x = 2 To Cells(65536, "F").End(xlUp).Row
srangea = Range("d2:d" & x).Address
srangeb = Range("h2:h" & x).Address
If Cells(x, "f") = "Var" Then
Cells(x, "h") = 1 + Evaluate("=sumproduct((" & srangea & "=""" & Cells(x, "d") & """)*(" & srangeb & "<>""" & "" & """))")
End If
Next x
End Sub
ikinci düğme için





Private Sub CommandButton2_Click()
Dim i As Long, son As Long
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
s1.Range("I2:I65000").ClearContents
a = 1
For x = 2 To s1.Cells(65536, "F").End(xlUp).Row
If Cells(x, "f") = "Yok" And Cells(x, "ı") = "" Then
Cells(x, "ı") = a
a = a + 1
For y = x + 1 To s1.Cells(65536, "F").End(xlUp).Row
If Cells(x, "d") = Cells(y, "d") And Cells(y, "f") = "Yok" Then
Cells(y, "ı") = a
a = a + 1
ElseIf Cells(y, "d") = Cells(x, "d") Then Exit For
End If
Next y
Else
a = 1
End If
a = 1
Next x
Application.ScreenUpdating = True
End Sub
denermisiniz.

Şükranlarımı sunuyorum. Eline Yüreğine Sağlık.

 

[apocalyt]

rica ederim..sizde saolun..