اريد تعديل هذا الكود

[خالد عبدالجواد]

اريد تعديل هذا الكود

Sub Test()
    Dim swb         As Workbook
    Dim twb         As Workbook
    Dim arr1        As Variant
    Dim arr2        As Variant
    Dim v           As Variant
    Dim d           As Object
    Dim m           As Long
    Dim n           As Long
    Dim r0          As Long
    Dim r           As Long
    Dim s           As Long
    Dim c           As Long

    Set swb = Workbooks("SerializePlantStockReport.xlsx")
    Set twb = ThisWorkbook
    
    Set d = CreateObject("Scripting.Dictionary")
    m = swb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    arr1 = swb.Sheets(1).Range("C2:E" & m).Value
    n = twb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    arr2 = twb.Sheets(1).Range("A2:B" & n).Value

    For s = 1 To n - 1
        v = arr2(s, 1)
        If d.exists(v) Then
            r0 = d(v)
        Else
            r0 = 0
        End If

        For r = r0 + 1 To m
            If arr1(r, 1) = v Then
                arr2(s, 2) = CStr(arr1(r, 3))
                d(v) = r
                Exit For
            End If
        Next r
    Next s

    twb.Sheets(1).Range("A2:B" & n).Value = arr2
End Sub

 

الكود موجود في شيت Picklist  عندما اقوم بنسخ الخليه C من شيت SerializePlantStockReport واضعها في شيت  Picklist الكود يعطيني الخانه E من شيت SerializePlantStockReport ويجب ان يكون شيت SerializePlantStockReport مفتوح . 

 

المطلوب تعديل الكود بحيث انسخ الخليه C من شيت Pick_List1 واضعها في شيت Picklist فيعطيني الخانه E ,F من شيت SerializePlantStockReport اذا كانت موجوده في شيت SerializePlantStockReport .

Downloads.rar

تم تعديل أغسطس 5, 2017 بواسطه khaled abdelgawad

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

السلام عليكم

أخي الكريم يراعى عند وضع الأكواد أن توضع بين أقواس الكود لتظهر بشكل منضبط

تفضل الكود التالي عله يكون المطلوب إن شاء العلي القدير

Sub Test()
    Dim swb         As Workbook
    Dim twb         As Workbook
    Dim arr1        As Variant
    Dim arr2        As Variant
    Dim v           As Variant
    Dim d           As Object
    Dim m           As Long
    Dim n           As Long
    Dim r0          As Long
    Dim r           As Long
    Dim s           As Long
    Dim c           As Long

    Set swb = Workbooks("SerializePlantStockReport.xlsx")
    Set twb = ThisWorkbook
    
    Set d = CreateObject("Scripting.Dictionary")
    m = swb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    arr1 = swb.Sheets(1).Range("C1:F" & m).Value
    n = twb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    arr2 = twb.Sheets(1).Range("A1:C" & n).Value
    
    For s = 1 To n
        v = CStr(Trim(arr2(s, 1)))
        If d.exists(v) Then
            r0 = d(v)
        Else
            r0 = 0
        End If

        For r = r0 + 1 To m
            If CStr(Trim(arr1(r, 1))) = CStr(Trim(v)) Then
                arr2(s, 2) = arr1(r, 3)
                arr2(s, 3) = arr1(r, 4)
                d(v) = r
                Exit For
            End If
        Next r
    Next s

    twb.Sheets(1).Range("A1:C" & n).Value = arr2
End Sub

 

[خالد عبدالجواد]

جزاكم الله خيرا فعلا هذا ما اريده ولكن عندما انسخ خانه C من شيت Pick_List1  لا يعطي  الخانه E ,F من شيت SerializePlantStockReport 

 

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

لربما يكون العنصر غير موجود أو أن البيانات غير صحيحة .. لأني لاحظت وجود مسافات زائدة .. قم بإزالة المسافات الزائدة وجرب مرة أخرى 

وجرب على عنصر تكون متأكد من تواجده

[خالد عبدالجواد]

جزاكم الله خيرا بالفعل الان الكود يقوم بما اريده 

شكرا جزيلا

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

وجزيت خيراً أخي الكريم بمثل ما دعوت لي والحمد لله أن تم المطلوب على خير

تقبل تحياتي