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

[ابو نبأ]

السلام عليكم

طلب مني عمل : وهي معرفة هل الكودات المراد بحثها موجودة في شيت الرئيسية (عندي قائمة رئيسية تحتوي على بيانات ، وعندي قائمة فرعية تحتوي على كودات ، المطلوب ترحيل الكود الموجود في شيت الفرعية الى شيت الكودات الموجودة ، علماً بان البيانات في شيت الرئيسية تحتوي على 55000 صف وشيت الفرعية تحتوي على 115 الف صف ) وارفق ملف توضيح بهذا الخصوص ، العمل المطلوب مستعجل ، وفقكم اختصروا عليه هذا العمل من خلال العلم الذي لديكم ، وفقكم الله وزادتكم علما

 

السلام عليكم

كودات.rar

تم تعديل يوليو 26, 2015 بواسطه ابو نبأ

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

أخي الفاضل أبو نبأ

إليك الكود التالي عله يكون المطلوب .. حاولت الابتعاد عن استخدام الحلقات التكرارية حتى يعمل الكود بكفاءة مع البيانات الكثيرة

اعتمدت في التفكير على استخدام الفلترة ... أي كل رقم كود أقوم بفلترته ثم نسخ البيانات المرتبطة بعملية الفلترة إلى آخر ورقة عمل

أرجو أن يكون المطلوب

Sub TransferDataBasedOnCode()
    Dim wsMain As Worksheet, wsBranch As Worksheet, SH As Worksheet
    Dim rngData As Range, Rng As Range, Cell As Range, LR As Long
    
    Set wsMain = Sheets("الرئيسية"): Set wsBranch = Sheets("الفرعية"): Set SH = Sheets("الكود الموجود")
    LR = IIf(wsBranch.Cells(Rows.Count, 1).End(xlUp).Row = 1, 2, wsBranch.Cells(Rows.Count, 1).End(xlUp).Row)
    Set Rng = wsBranch.Range("A2:A" & LR)
    Set rngData = wsMain.Range("A1:K" & wsMain.Cells(Rows.Count, 1).End(xlUp).Row)
    
    Application.ScreenUpdating = False
        If Application.WorksheetFunction.CountA(Rng) < 1 Then MsgBox "لا يوجد أرقام كود لترحيلها", vbInformation: Exit Sub
        For Each Cell In Rng
            With wsMain
                .AutoFilterMode = False
                .Range("A1:K1").AutoFilter Field:=2, Criteria1:=Cell.Value
                If rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then GoTo Skipper
                rngData.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
                SH.Range("A" & SH.Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteValues
            End With
Skipper: Next Cell
        wsMain.AutoFilterMode = False
        SH.Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

لا تنسى أن تحدد أفضل إجابة ولو فيها تعب ليك اضغط على "أعجبني هذا" إذا أعجبك الحل

تقبل تحياتي :fff:

Transfer Data Based On Code.rar

[ابو نبأ]

السلام عليكم

جزيت خيرا - شكرا على سرعة المرور - وفقكم الله

 

العمل الممتاز يستهال مو بس افضل اجابة او اعجاب بل الدعاء له بالتوفيق والتيسير وزيادة في العلم والعمل

 

وفقكم الله

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

وعليكم السلام أخي الكريم أبو نبأ

الحمد لله أن تم المطلوب على خير

ومشكور على اختيارك أفضل إجابة والضغط على "أعجبني"

تقبل وافر تقديري واحترامي

[ابوزيد]

أي والله تستهال - انجزت العمل المطلوب بسرعة وسلمته

انته صاحب فضل - جزيت خيرا  وفقك الله

تم تعديل يوليو 26, 2015 بواسطه ابوزيد

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

أخي الكريم

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

فاللهم لك الحمد ربي ملء السماوات وملء الأرض وملء ما بينهما وملء ما شئت من شيء بعد

 

تقبل وافر تقديري واحترامي

[۩◊۩ أبو حنين ۩◊۩]

اخى الحبيب ياسر خليل

سلمت يداك ... دائما عون  لجميع اعضاء المنتدى

جزاك الله كل الخير