اخر بيانات في صف

[tahar]

السلام عليكم

هل يوجد كود او دالة عند ادخال كود ياتي باخر ادخال في الضف

الشرح في المرفق

ppp.rar

[محمد هشام.]

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

جرب هدا 

=IFERROR(IF(A14="","",LOOKUP(2,1/(INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0)<>""),INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0))),"بدون نتيجة")

 أو  بإستخدام  vba 

 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Code As Variant, dataA As Variant, dataB As Variant
    Dim rngA As Range, rngB As Range, rngC As Range
    Dim tmp As Variant, result As String
    Dim cell As Range, col As Long

    Dim msg As String: msg = "بدون نتيجة"
    
    Set rngA = Me.Range("A2:A9")
    Set rngB = Me.Range("B2:E9")
    Set rngC = Me.Range("A14:A21")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo CleanExit
    If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then
        dataA = rngA.Value
        dataB = rngB.Value
       For Each cell In rngC
            If Trim(cell.Value) <> "" Then
                tmp = Application.Match(cell.Value, rngA, 0)
                
                If Not IsError(tmp) Then
                    result = msg
                    For col = 4 To 1 Step -1
                        If Trim(dataB(tmp, col)) <> "" Then
                            result = dataB(tmp, col)
                            Exit For
                        End If
                    Next col
                    cell.Offset(0, 1).Value = result
                Else
                    Code = cell.Value
                    cell.Resize(1, 2).ClearContents
                    MsgBox "الكود " & Code & " غير موجود", vbExclamation
                End If
            Else
                cell.Offset(0, 1).ClearContents
            End If
        Next cell
    End If

CleanExit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

 

 

ppp.xlsb

تم تعديل أكتوبر 16 بواسطه محمد هشام.

[عبدالله بشير عبدالله]

ما شاء الله استاذ محمد معادلة وكود . اثراء للموضوع المعادلة التالية تؤدى الى نفس النتيجة   وهى تستخدم دالة AGGREGATE لتحديد آخر عمود يحتوي على قيمة غير فارغة، ومن ثم دالة INDEX لاسترجاع القيمة المطابقة. 

المعاداة

=IFERROR(
    IF(A14=""; "";
    INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); AGGREGATE(14; 6; COLUMN($B$2:$E$2) / (INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); 0)<>""); 1) - COLUMN($B$2) + 1)
    );
"بدون نتيجة")

الملف

اخر ادخال بالصف.xlsx

 

[tahar]

شكرا لكم على المساعدة

ممكن تعديل قمت بتغيير مكان الجدول ومكان جلب النتيجة في ورقة أخرى حاولت ولم تنجح

ppp6.rar

[محمد هشام.]

=IF(A14="","",IFERROR(LOOKUP(2,1/(INDEX($L$2:$O$9,MATCH(A14,$K$2:$K$9,0),0)<>"")
,INDEX($L$2:$O$9,MATCH(A14,$K$2:$K$9,0),0)),"بدون نتيجة"))

معادلة الأستاد @عبدالله بشير عبدالله

=IFERROR(
    IF(A14="", "",
    INDEX($L$2:$O$9, MATCH(A14, $K$2:$K$9, 0), AGGREGATE(14, 6, COLUMN($L$1:$O$1) / (INDEX($L$2:$O$9, MATCH(A14, $K$2:$K$9, 0), 0)<>""), 1) - COLUMN($L$1) + 1)
    ),
"بدون نتيجة")

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngA As Range, rngB As Range, rngC As Range
    Dim tmp As Variant, result As String
    Dim cell As Range, col As Long
    Dim msg As String: msg = "بدون نتيجة"
    
    Set rngA = Me.Range("K2:K9")
    Set rngB = Me.Range("L2:O9")
    Set rngC = Me.Range("A14:A21")

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then
        For Each cell In rngC
            If Trim(cell.Value) <> "" Then
                tmp = Application.Match(cell.Value, rngA, 0)
                If Not IsError(tmp) Then
                    result = msg
                    For col = 4 To 1 Step -1
                        If Trim(rngB.Cells(tmp, col).Value) <> "" Then
                            result = rngB.Cells(tmp, col).Value
                            Exit For
                        End If
                    Next col
                    cell.Offset(0, 1).Value = result
                Else
                    cell.Resize(1, 2).ClearContents
                    MsgBox "الكود " & cell.Value & " غير موجود", vbExclamation
                End If
            Else
                cell.Offset(0, 1).ClearContents
            End If
        Next cell
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

ppp6.xlsb

تم تعديل أكتوبر 22 بواسطه محمد هشام.

[tahar]

السلام عليكم 

النتائج يجلبها في الورقة  natiga وليس في نفس الورقة 

[محمد هشام.]

ضع الأكواد التالية  في حدث ورقة natiga 

Private Sub Worksheet_Activate()
    UpdateData
End Sub
'============
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("A10:A25")) Is Nothing Then
        UpdateData
    End If
End Sub
'===========
Private Sub UpdateData()
    Dim ColmA As Variant, msg As String, i As Long, tmp As Variant, col As Long
    Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Feuil1")
    Dim item As Range: Set item = WS.Range("K2:K9")
    Dim data As Range: Set data = WS.Range("L2:O9")

    For i = 10 To 25
        ColmA = Me.Range("A" & i).Value
        Me.Range("B" & i).ClearContents

        If Trim(ColmA) = "" Then GoTo lig

        On Error Resume Next
        tmp = Application.Match(ColmA, item, 0)
        On Error GoTo 0

        If Not IsError(tmp) Then
            msg = "بدون نتيجة"
            For col = data.Columns.Count To 1 Step -1
                If Trim(data.Cells(tmp, col).Value) <> "" Then
                    msg = data.Cells(tmp, col).Value
                    Exit For
                End If
            Next col
            Me.Range("B" & i).Value = msg
        Else
            Me.Range("A" & i).Resize(1, 2).ClearContents
            MsgBox "الكود " & ColmA & " غير موجود", vbExclamation
        End If
        
lig:
    Next i
End Sub

المعادلة 

=IF(A10="","",IFERROR(LOOKUP(2,1/(INDEX(Feuil1!$L$2:$O$9,
MATCH(A10,Feuil1!$K$2:$K$9,0),0)<>""),INDEX(Feuil1!$L$2:$O$9,MATCH(A10,Feuil1!$K$2:$K$9,0),0)),"بدون نتيجة"))

 

ppp7.xlsb

[tahar]

شكرا هذا هو التعديل المطلوب شكرا لكم  وجزاكم الله كل خير 

[محمد هشام.]

العقو اخي @tahar