برمجة vba للدالة xlookup

[hema_elgendy]

السلام عليكم 

كنت محتاج يا شباب جملة برمجة vba  مطابقة للدالة xlookup بنفس مدخلتها لوضعها فى اى اصدار للاوفس بحيث تكون بديلة عن الدالة الاساسية المستخدمة فى اوفس 365 .

[Ali Mohamed Ali]

وعليكم السلام -على الرغم انك لم تقم برفع ملف موضح فيه كل المطلوب الا انك يمكنك استخدام هذا

Public Function XLookup(ByVal vTable As Variant, _
                        ByVal vResult As Variant, _
                   ParamArray vKeyVals() As Variant) As Variant
    Const cRoutine      As String = "XLookup"
    Dim oLo             As ListObject   'Table containing data
    Dim vKeys           As Variant      'vKeyVals internal version
    Dim sCol            As String       'Column Address Range to search
    Dim vKey            As Variant      'Key(s) to find in Column(s)
    Dim lKey            As Long         'Current key
    Dim lRow            As Long         'Found Row
    Dim lCol            As Long         'Found Column
    Dim sAddTxt         As String       'Additional Error Text
   
'   Error Handling Initialization
    On Error GoTo ErrHandler
    Set XLookup = Nothing

'   Check Inputs and Requisites
'   Table
    Select Case TypeName(vTable)
        Case Is = "ListObject": Set oLo = vTable
        Case Is = "Range":      Set oLo = vTable.ListObject
        Case Else:              Set oLo = ActiveSheet.Evaluate(vTable).ListObject
    End Select
'   Return Column
    If TypeName(vResult) = "Range" Then vResult = vResult.Value2
'   Search Keys
    If UBound(vKeyVals) = -1 Then Err.Raise DspError, , "#Key(s) required"
'   When called by VBA, ParamArrays sometimes are stuffed in the first element
    If IsArray(vKeyVals(LBound(vKeyVals))) Then _
        vKeys = vKeyVals(LBound(vKeyVals)) Else _
            vKeys = vKeyVals
    
'   Procedure
    With oLo
        If Not .DataBodyRange Is Nothing Then
        '   Just 1 key - Use Worksheet.Function because it is fastest w/1 Key
            If LBound(vKeys) = UBound(vKeys) Then
                vKey = vKeys(UBound(vKeys))
                If IsNumeric(vKey) Then vKey = CDbl(vKey)
                lRow = Application.WorksheetFunction.Match( _
                            vKey, _
                            .ListColumns(1).DataBodyRange, _
                            0)
        '   More than 1 key - Use Worksheet.Evaluation because it is fastest w/multiple keys
            Else
            '   Concatenate Key Values and Search Column Addresses
                For lKey = LBound(vKeys) To UBound(vKeys)
                    lCol = lCol + 1
                    sCol = IIf(sCol <> vbNullString, sCol & " & ", vbNullString) & _
                        .ListColumns(lCol).DataBodyRange.Address
            '   Determine Key Value
                If TypeName(vKeys(lKey)) = "Range" Then _
                    vKey = vKey & vKeys(lKey).Value2 Else _
                        If IsDate(vKeys(lKey)) Then _
                            vKey = vKey & CLng(vKeys(lKey)) Else _
                                vKey = vKey & vKeys(lKey)
                Next
            '   Find Row # by Evaluating MATCH within the Table's worksheet
                lRow = .Parent.Evaluate("=Match(""" & vKey & """," & sCol & ",0)")
            End If
        '   Get Column #
            lCol = .ListColumns(vResult).Index
        '   Return result
            Set XLookup = .ListRows(lRow).Range(lCol)
         End If
    End With
    
ErrHandler:
    If Err.Number > 0 Then
    '   Create sAddTxt (Additional Error Text) if needed
        Select Case Err.Number
            Case Is = 9:        sAddTxt = "Column " & vResult & " not found in " & oLo.Name
            Case Is = 13, 1004: sAddTxt = "Key(s) " & Join(vKeys, ",") & " not found" 
            Case Is = 424:      sAddTxt = "Table not found"
        End Select
    '   Customize Errors based on UDF of VBA caller
        If TypeName(Application.Caller) = "Range" Then      'Called from UDF
            MLookup = CVErr(xlErrRef)
            Debug.Print cRoutine & ":" & Err.Description & vbLf & sAddTxt
        Else                                                'Called from VBA (most likely)
            Select Case Err.Number
                Case Is = 13, 1004:                         'Key(s) not found. Log Error
                    Debug.Print cRoutine & Err.Description & vbLf & sAddTxt
                Case Else:                                  'Pop Up Error Message  
                    Select Case DspErrMsg(cModule & "." & cRoutine, sAddTxt)
                        Case Is = vbAbort:  Stop: Resume    'Debug mode - Trace
                        Case Is = vbRetry:  Resume          'Try again
                        Case Is = vbIgnore:                 'End routine
                    End Select
            End Select
        End If
    End If
    
End Function

أو يمكنك مشاهدة هذا الرابط

Custom Excel XLOOKUP Function

أو هذا الرابط

UDF: XLOOKUP – Using VLOOKUP for left AND right searches

وهذا ايضا فيديو للشرح

https://www.youtube.com/watch?v=Tbqh4_HcUlI

 

[abouelhassan]

شكر وتقدير واحترام استاذنا على

[أحمد يوسف]

hema_elgendy

انت فين من ده كله اين الضغط على الإعجاب لكل هذه الإجابات الرائعة ؟!!!💙