المساعدة في دمج اكواد

[أبو قاسم]

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

الكود الاول 

 

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

Dim R As Integer

If Not Intersect(Target.Cells(1, 1), Union(Range("D2:D10000"), Range("o2:o10000"))) Is Nothing Then

    R = Target.Row

    If Cells(R, "D").Value <> "" Then

        Cells(R, "0").Value = R + 4999

        Cells(R, "E").Value = WorksheetFunction.VLookup(Cells(R, "D"), [TUNNEL6], 2, 0)

        Cells(R, "F").Value = WorksheetFunction.VLookup(Cells(R, "D"), [TUNNEL6], 3, 0)

        Cells(R, "G").Value = WorksheetFunction.VLookup(Cells(R, "D"), [TUNNEL6], 4, 0)

    Else

        Union(Cells(R, "0"), Cells(R, "0")).ClearContents

    End If

End If

On Error GoTo 0

End Sub

الكود الثاني 

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

Dim R As Integer

If Not Intersect(Target.Cells(1, 1), Union(Range("c2:c10000"), Range("o2:o10000"))) Is Nothing Then

    R = Target.Row

    If Cells(R, "c").Value <> "" Then

        Cells(R, "0").Value = R + 4999

        Cells(R, "l").Value = WorksheetFunction.VLookup(Cells(R, "c"), [TUNNEL3], 2, 0)

    Else

        Union(Cells(R, "0"), Cells(R, "0")).ClearContents

    End If

End If

On Error GoTo 0

End Sub

 

الحل لوسمحتوا

[ياسر خليل أبو البراء]

الأخ الكريم

أهلا بك في المنتدى ومرحبا بك بين إخوانك

 

يرجى تغيير اسم الظهور للغة العربية

 

لمعرفة المزيد من التفاصيل يرجى مراجعة هذا الرابط للضرورة

http://www.officena.net/ib/index.php?showtopic=60147

 

بالنسبة للكود يوضع بين أقواس تنصيص أو الأفضل قم بإرفاق ملفك وأعطي الأعضاء نبذة عن الهدف من كل كود لتسهل عملية المساعدة

تقبل تحياتي

[ياسر خليل أبو البراء]

إلى أن تقوم برفع ملف جرب الكود بهذا الشكل ..

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim R As Integer
    On Error Resume Next
        If Not Intersect(Target.Cells(1, 1), Union(Range("D2:D10000"), Range("O2:O10000"))) Is Nothing Then
            R = Target.Row
            If Cells(R, "D").Value <> "" Then
                Cells(R, "O").Value = R + 4999
                Cells(R, "E").Value = WorksheetFunction.VLookup(Cells(R, "D"), [TUNNEL6], 2, 0)
                Cells(R, "F").Value = WorksheetFunction.VLookup(Cells(R, "D"), [TUNNEL6], 3, 0)
                Cells(R, "G").Value = WorksheetFunction.VLookup(Cells(R, "D"), [TUNNEL6], 4, 0)
            Else
                Union(Cells(R, "O"), Cells(R, "O")).ClearContents
            End If
        End If
        
        If Not Intersect(Target.Cells(1, 1), Union(Range("C2:C10000"), Range("O2:O10000"))) Is Nothing Then
            R = Target.Row
            If Cells(R, "C").Value <> "" Then
                Cells(R, "O").Value = R + 4999
                Cells(R, "l").Value = WorksheetFunction.VLookup(Cells(R, "C"), [TUNNEL3], 2, 0)
            Else
                Union(Cells(R, "O"), Cells(R, "O")).ClearContents
            End If
        End If
    On Error GoTo 0
End Sub

ولكن الكود غير مفهوم بالنسبة لي .... ومبهم في بعض الأسطر .. ولاحظت أن في الكود رقم 0 وأعتقد أن الصحيح هو أن الصفر يجب استبدالة بحرف الـ O

عموما جرب قد يكون المطلوب

[أبو قاسم]

اشكرك على الاستجابة يعمل الكود الثاني الاول لايعمل بيكون صفر 

[أبو قاسم]

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