2 Tarih Arası Benzersiz Liste

[1Al2Ver]

Merhaba,

2 Tarih arasında, başka sayfada kayıtlı çizelgeden,

Rapor sayfasına, örnekteki gibi yeni bir çizelge almak istiyorum.

Teşekkür ederim.

 

[Merhum İdris SERDAR]

.

Dosyanız ekte.

Özet Tablo ile yapılmıştır.


.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub test()
Sayfa2.[m6:p1000] = ""
s = 1
son = Sayfa1.Cells(Rows.Count, "a").End(xlUp).Row
ReDim veri(1 To son, 1 To 4) As Variant
For satm = 2 To Sayfa1.Cells(Rows.Count, "a").End(xlUp).Row
    If WorksheetFunction.CountIf(Sayfa1.Range("b2:b" & satm), Sayfa1.Cells(satm, "b")) = 1 Then
    If Sayfa1.Cells(satm, "a") >= Sayfa2.[o1] And Sayfa1.Cells(satm, "a") <= Sayfa2.[p1] Then
        veri(s, 1) = Sayfa1.Cells(satm, "b")
        veri(s, 2) = Sayfa1.Cells(satm, "c")
        veri(s, 3) = Sayfa1.Cells(satm, "d")
        veri(s, 4) = Sayfa1.Cells(satm, "e")
        s = s + 1
    End If
    End If
Next
Sayfa2.Range("m6").Resize(s, 4) = veri
End Sub

Makro ile çözüm.

 

[Orion1]

Merhaba,

2 Tarih arasında, başka sayfada kayıtlı çizelgeden,

Rapor sayfasına, örnekteki gibi yeni bir çizelge almak istiyorum.

Teşekkür ederim.

Dosyanız ektedir.

Option Base 1
Sub aktar_benzersiz59()
Dim z As Object, i As Long, sonsat As Long, liste(), myarr()
Dim sh As Worksheet, ilk As Date, son As Date
Set sh = Sheets("MALZEME_ÇIKIŞI")
Sheets("RAPOR").Select
Range("M6:P" & Rows.Count).ClearContents
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
liste = sh.Range("A2:E" & sonsat).Value
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 4, 1 To sonsat)
For i = 1 To UBound(liste)
    If liste(i, 1) >= Range("O1").Value And liste(i, 1) _
            <= Range("P1").Value Then
        If Not z.exists(liste(i, 2)) Then
            n = n + 1
            z.Add liste(i, 2), n
            myarr(1, n) = liste(i, 2)
            myarr(2, n) = liste(i, 3)
        End If
        myarr(3, z.Item(liste(i, 2))) = myarr(3, z.Item(liste(i, 2))) + liste(i, 4)
        myarr(4, z.Item(liste(i, 2))) = myarr(4, z.Item(liste(i, 2))) + liste(i, 5)
    End If
Next i
ReDim Preserve myarr(1 To 4, 1 To n)
If z.Count < 1 Then Exit Sub
Application.ScreenUpdating = False
Range("M6").Resize(z.Count, 4) = Application.Transpose(myarr)
Erase liste: Set z = Nothing
Application.ScreenUpdating = True
MsgBox "Bitti." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Ziynettin]

Bende yazmıştım. Alternatif olsun.

Option Explicit
Sub aktar()
Dim a(), b(), d As Object
Dim i As Long, Say As Long, x As Long, p As Long
Dim Trh_1 As Date, Trh_2 As Date
Dim S1 As Worksheet, S2 As Worksheet, deg
Set S1 = Sheets("MALZEME_ÇIKIŞI")
Set S2 = Sheets("RAPOR")
Set d = CreateObject("scripting.dictionary")
a = S1.Range("A2:E" & S1.Cells(Rows.Count, 1).End(3).Row).Value
Trh_1 = S2.[O1]
Trh_2 = S2.[P1]
For i = 1 To UBound(a)
If Trh_1 <= a(i, 1) And Trh_2 >= a(i, 1) Then
deg = a(i, 2)
If Not d.exists(deg) Then
Say = Say + 1
d(deg) = Say
End If
End If
Next i
ReDim b(1 To d.Count, 1 To 4)
For x = LBound(a) To UBound(a)
If Trh_1 <= a(x, 1) And Trh_2 >= a(x, 1) Then
p = d(a(x, 2))
b(p, 1) = a(x, 2)
b(p, 2) = a(x, 3)
b(p, 3) = b(p, 3) + a(x, 4)
b(p, 4) = b(p, 4) + a(x, 5)
End If
Next x
If Say > 0 Then
S2.Range("M6:P" & Rows.Count).ClearContents
S2.Range("M6").Resize(d.Count, 4) = b
S2.Range("O6").Resize(d.Count, 2).NumberFormat = "#,##0.00"
End If
MsgBox "İşlem tamam.."
End Sub

 

[1Al2Ver]

Sayın,

İdris Serdar
N.Ziya Hiçdurmaz
Orion1
Ziynettin,

Öncelikle duyarlığınız ve değerli çözümleriniz için çok teşekkür ederim, iyi ki varsınız.

Saygılarımla.

 

[Orion1]

Sayın,

İdris Serdar
N.Ziya Hiçdurmaz
Orion1
Ziynettin,

Öncelikle duyarlığınız ve değerli çözümleriniz için çok teşekkür ederim, iyi ki varsınız.

Saygılarımla.

Rica ederim.
İyi çalışmalar.

 

[isteobenim]

Rica ederim.
İyi çalışmalar.

Merhaba,

Benimde kullanacak olacağım bir çalışma olduğu için bende teşekkür ederim.

Sağolun...

 

[Orion1]

Merhaba,

Benimde kullanacak olacağım bir çalışma olduğu için bende teşekkür ederim.

Sağolun...

Rica ederim.
İyi çalışmalar.