معادلة بدون تكرار لثلاثة أعمدة

[كمال على طارق]

السلام عليكم أساتذتى الكرام وكل عام وأنتم بخير وعيد أضحى سعيد على الجميع ... الرجاء من سيادتكم التكرم على مساعدتى بمعادلة لجلب البيانات من ثلاثة أعمدة بدون تكرار . بمعنى جلب بيانات العمود M من صفحة Data ,ووضعها بالعمود A بصفحة Total وبيانات العمود O واحضارها بالعمود B بصفحة Total وبيانات العمود P من صفحة Data ووضعها بالعمود C بصفحة Total .. وهناك نتيجة موجودة بالصفحة Total كمثال لما هو مطلوب  وجزاكم الله خير الثواب وبارك الله فى جهودكم

لابد الا يتكرر اسم الرحلة مع اسم المندوب لنفس التاريخ    وشكرا جزيلا

معادلة بدون تكرار.xlsx

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

إدا كنت تستخدم نسخة حديثة من الأوفيس إستخدم المعادلة التالية 

=LET(data, Sheet!A2:P1000,
tour, INDEX(data,,13), date_, INDEX(data,,15), guide, INDEX(data,,16),
keys, UNIQUE(FILTER(tour & "|" & guide & "|" & TEXT(date_,"dd/mm/yyyy"), (tour<>"")*(guide<>"")*(date_<>""))),
rowNums, XMATCH(keys, tour & "|" & guide & "|" & TEXT(date_,"dd/mm/yyyy")),
CHOOSE({1,2,3,4,5}, INDEX(data, rowNums, 13), TEXT(INDEX(data, rowNums, 15),"dd/mm/yyyy"),
INDEX(data, rowNums, 16), INDEX(data, rowNums, 1), INDEX(data, rowNums, 2)))

 

أو يمكنك إستخدام الكود التالي 

في Module

Sub UpdateColArr()
    Const ColA = 1, ColB = 2, ColM = 13, ColO = 15, ColP = 16
    Dim OnRng, dict As Object, a(), key As String
    Dim i As Long, tmps As Long
    Dim WS As Worksheet: Set WS = Sheets("Sheet")
    Dim dest As Worksheet: Set dest = Sheets("Sheet1")
    Set dict = CreateObject("Scripting.Dictionary")
    
   SetApp False
   With dest
        .Range("A1:E" & .Rows.Count).ClearContents
        .Range("A1").Resize(1, 5).Value = [{"Tour Name","Tour Date","Guide Name","Adl.","Chd"}]
        With .Range("A1:E1").Borders: .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic: End With
   End With
   
    OnRng = WS.Range("A2:P" & WS.Cells(WS.Rows.Count, ColM).End(xlUp).Row).Value
    ReDim a(1 To UBound(OnRng), 1 To 5)

    For i = 1 To UBound(OnRng)
        If Trim(OnRng(i, ColM)) <> "" Then
            key = OnRng(i, ColM) & "|" & OnRng(i, ColO) & "|" & OnRng(i, ColP)
            If Not dict.exists(key) Then
                tmps = tmps + 1
                a(tmps, 1) = OnRng(i, ColM): a(tmps, 2) = OnRng(i, ColO)
                a(tmps, 3) = OnRng(i, ColP): a(tmps, 4) = OnRng(i, ColA): a(tmps, 5) = OnRng(i, ColB)
                dict.Add key, 1
            End If
        End If
    Next i

    If tmps > 0 Then dest.Range("A2").Resize(tmps, 5).Value = a
    SetApp True
    Set dict = Nothing: Set WS = Nothing: Set dest = Nothing
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    On Error Resume Next
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
    On Error GoTo 0
End Sub

وفي حدث ورقة Sheet2

Private Sub Worksheet_Activate()
On Error Resume Next: Call UpdateColArr: On Error GoTo 0
End Sub

 

 

 

 

معادلة بدون تكرار v1.xlsb

تم تعديل منذ 52 دقائق بواسطه محمد هشام.