رفع مشکل اخرین تاریخ هر محصول

**M_ExceL** · 2020/11/05, 00:00

نوشته اصلی توسط hesabrainian253

سلام بر اساتید

من چند روز گذشته یه سوال در مورد اخرین تاریخ ثبت یه محصول مطرح کردم که اساتید لطف کردید جواب دادید .
سوال این بود که چه جوری میشه در یک اکسل اخرین تاریخ یک محصول که با چند تاریخ ثبت شده را مشخص کرد
ولی امروز دیدم یه مشکلی داره میخاستم ببینم جه جوری میشه رفعش کنم
قیمت های تاریخ فایل اصلی با با فایلی که در اون فرمول نوشته شده با هم متفاوت هستن
مثلا در فایل اصلی
کد 816023 در تاریخ 29/06/1399 به مبلغ 67500 بوده

ولی در فایلی که فرمول نویسی شده مبلغ شده 62500

من هر دو اکسل را ‍‍‍پیوست کردم

ممنون اگه راهنمایی کنید

[ATTACH=CONFIG]21870[/ATTACH]

[ATTACH=CONFIG]21871[/ATTACH]

[ATTACH]21869[/ATTACH]

[ATTACH]21872[/ATTACH]

با سلام،
می تونید از کد زیر طبق فایل پیوست استفاده کنید :

کد:

Sub M_ExceL()

        Dim A As Variant
        
        Dim UV As Variant
        
        Dim r() As Variant

        lstr = Sheets(1).Cells(Rows.Count, 3).End(3).Row
        
        UV = Uvalues(Sheets(1).Range("c2:c" & lstr))

        ReDim r(LBound(UV) To UBound(UV), 1 To 9)

            For itm = LBound(UV) To UBound(UV)
                A = CountD(Sheets(1).Range("a2:i" & lstr), CStr(UV(itm)))
                For c = 1 To 9
                    r(itm, c) = A(1, c)
                Next
            Next


        Sheets(2).Range("a1:i1").value = Sheets(1).Range("a1:i1").value
        
        Sheets(2).Range("a2:i" & UBound(UV)).value = r

End Sub

Function Uvalues(rng As Range) As Variant
Dim coll As New Collection
Dim A1 As Variant
Dim A2() As Variant
A1 = rng.value
On Error Resume Next
For Each itm In A1
    If itm <> Empty Then
        coll.Add CStr(itm), CStr(itm)
    End If
Next
On Error GoTo 0
ReDim A2(1 To coll.Count)
For i = 1 To coll.Count
    A2(i) = coll.Item(i)
Next
Uvalues = A2
End Function

Function CountD(rng As Range, val As Variant) As Variant
Dim A As Variant
Dim DA() As Long
Dim AA(1 To 1, 1 To 9) As Variant
Dim v As Integer
A = rng.value
v = 0
For i = LBound(A) To UBound(A)
    If CStr(A(i, 3)) = val Then
        v = v + 1
        ReDim Preserve DA(1 To v)
        DA(v) = Int(Replace(A(i, 2), "/", ""))
    End If
Next
s = Str(WorksheetFunction.Max(DA))
y = Mid(s, 1, 5) + "/"
m = Mid(s, 6, 2) + "/"
d = Mid(s, 8, 2)
MAXD = Replace((y + m + d), " ", "")
For i = LBound(A) To UBound(A)
    If CStr(A(i, 3)) = val And A(i, 2) = MAXD Then
        For c = 1 To 9
            AA(1, c) = A(i, c)
        Next
        Exit For
    End If
Next
CountD = AA
End Function

در فایل پیوست ابتدا ماکرو را فعال کنید سپس روی Button 1 کلیک کنید
منتظربمانید تا عملیات لازم صورت پذیرد سپس نتیجه را بررسی نمایید

فایل های پیوست شده