- Katılım
- 18 Nisan 2008
- Mesajlar
- 1,104
- Excel Vers. ve Dili
- office2010
Merhaba,Merhaba değerli hocalarım,
2 nolu mesajdaki Sayın @Ömer BARAN' ın "Kriterli_listeleme" makrosunu, benzer bir çalışmaya uyarlamaya çalıştım. Fakat işin içinden çıkamadım. Detayları ekli dosya üzerinde belittim. Tekrar yardımlarınızı rica ediyorum.
Yukarıda, benzer bir çalışmadaki sayın @Ziynettin' e ait kod gerçekten çok hızlı. Ekteki çalışmayı da aynı yöntemle yapabilir miyiz?
İyi günler dilerim.
Ömer Bey, çözüm sunmuş. Bu da alternatif olsun.
Kod:
Sub Listele()
Dim s1 As Worksheet, s2 As Worksheet, a(), b()
Dim t1 As Date, t2 As Date, sicil As String
Set s1 = Sheets("Data")
Set s2 = Sheets("Mutabakat")
t1 = s2.[F5]: t2 = s2.[F6]: sicil = [i3]
a = s1.Range("A2:J" & s1.Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 6)
For i = 1 To UBound(a)
If CStr(a(i, 1)) = sicil Then
If a(i, 7) >= t1 And a(i, 8) <= t2 Then
say = say + 1
b(say, 1) = a(i, 4)
b(say, 2) = a(i, 5)
b(say, 3) = a(i, 7)
b(say, 4) = a(i, 8)
b(say, 5) = a(i, 9)
b(say, 6) = a(i, 10)
End If
End If
Next i
s2.Range("A21:F" & Rows.Count).ClearContents
If say > 0 Then
s2.[B21].Resize(say).NumberFormat = "@"
s2.[C21].Resize(say, 3).NumberFormat = "dd.mm.yyyy"
s2.[F21].Resize(say).NumberFormat = "#,##0.00"
s2.[A21].Resize(say, 6) = b
End If
MsgBox "İşlem bitti.", vbInformation
End Sub