LİSTELEME

[agunes4242]

listelerken tarihe göre listeleme yapabilir mi veri listedeki tarih karışık bide 6 satırdaki not karşılığına sabit yazı bir not yazacam yardımcı olursanız sevinirim.

 

[Necdet]

Merhaba,
Kodları Modüle değil Sayfa bölümüne kopyalamışsınız.
VERİ sayfasındaki başlıkları kendi kafama göre doldurdum, çünkü boşluk olmaması gerek, kodları ona göre kodladım.
LİSTE sayfasında anlaşılması için açıklama ve resim ekledim.

Listenin tarih sıralı çıkmasını istediğiniz için Sıralama Fonksiyonu ekledim.
Eğer VERİ sayfasını tarihe göre sıralarsanız bu fonksiyonu kullanmaya gerek kalmaz.

Sub Listele()

Dim arr As Variant
Dim diz(1 To 6, 1 To 3) As Variant
Dim i   As Long
Dim j   As Long
Dim adt As Integer
Dim tar1 As Date
Dim tar2 As Date

Application.ScreenUpdating = False

Sayfa2.Range("A:C").ClearContents
diz(1, 2) = Sayfa1.Cells(1, 9)
diz(2, 2) = Sayfa1.Cells(1, 5)
diz(3, 2) = Sayfa1.Cells(1, 6)
diz(4, 2) = Sayfa1.Cells(1, 20)
diz(5, 2) = Sayfa1.Cells(1, 21)
diz(6, 2) = "NOT"


tar1 = Sayfa2.Range("F2")
If tar1 = "00:00:00" Then tar1 = Application.WorksheetFunction.Min(Sayfa1.Range("T:T"))
tar2 = Sayfa2.Range("F3")
If tar2 = "00:00:00" Then tar2 = Application.WorksheetFunction.Max(Sayfa1.Range("T:T"))

j = 2

arr = Sayfa1.Range("A3").CurrentRegion.Value
arr = Array_Sort(arr, 2, , 20)

For i = 2 To UBound(arr, 1)
    If arr(i, 20) >= tar1 And arr(i, 20) <= tar2 Then
        adt = adt + 1
        diz(1, 1) = adt
        diz(1, 3) = arr(i, 9)
        diz(2, 3) = arr(i, 5)
        diz(3, 3) = arr(i, 6)
        diz(4, 3) = arr(i, 20)
        diz(5, 3) = arr(i, 21)
        diz(6, 3) = Sayfa2.Range("H2")
        Sayfa2.Cells(j, "A").Resize(6, 3) = diz
        j = j + 7
    End If
Next i

Application.ScreenUpdating = True
MsgBox adt & " ADET KAYIT AKTARILMIŞTIR ...."

End Sub

Function Array_Sort(ByRef sortArray As Variant, _
                           Optional firstRow As Long = 1, _
                           Optional lastRow As Long = 0, _
                           Optional searchCol As Integer = 1, _
                           Optional numericSort As Boolean = False, _
                           Optional ascendingOrder As Boolean = True) As Variant()

Dim temp As Variant
Dim firstCol As Long
Dim lastCol As Long
Dim i As Long
Dim j As Long
Dim k As Long

If lastRow = 0 Then lastRow = UBound(sortArray, 1)
firstCol = LBound(sortArray, 2)
lastCol = UBound(sortArray, 2)
For i = firstRow To lastRow - 1
    For j = i + 1 To lastRow
        If (numericSort And ascendingOrder And sortArray(i, searchCol) > sortArray(j, searchCol)) _
        Or (Not (numericSort) And ascendingOrder And StrComp(sortArray(i, searchCol), sortArray(j, searchCol)) = 1) _
        Or (numericSort And Not (ascendingOrder) And sortArray(i, searchCol) < sortArray(j, searchCol)) _
        Or (Not (numericSort) And Not (ascendingOrder) And StrComp(sortArray(i, searchCol), sortArray(j, searchCol)) = -1) Then
            For k = firstCol To lastCol
                temp = sortArray(j, k)
                sortArray(j, k) = sortArray(i, k)
                sortArray(i, k) = temp
            Next k
        End If
    Next j
Next i

Array_Sort = sortArray

End Function