طلب كود ترحيل

[محمد السباعي]

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

برجاء من الاخوة الاحباء عمل كود ترحيل للمرفق للضرورة

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

ترحيل الي الفرعي (4).rar

[سليم حاصبيا]

ربما يكون الحل هنـا

transfer salim.rar

[محمد السباعي]

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

اللهم بارك عمل اكثر من رائع انا كنت اشعر ان هذا الامر مستحيل تنفيذه و قد حاولت فترة طويلة انفذ الموضوع ولكن لم اوفق لذا ارسلته الي موقعكم المبارك الذي اتعلم منه كل يوم وجزاكم الله خيرا 

برجاء اذا امكن عمل شرح للكود حتي استفيد اكثر من علمكم من مبدا  لاتعطني سمكة ولكن علمني كيف اصطاد ولك مني جزيل الشكر و العرفان و بارك الله في اهلك و مالك ودارك و عملك و ولدك

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

أخي الحبيب سليم بارك الله فيك وجزاك الله كل خير

بينما كنت تقدم الحل لأخونا محمد السباعي كنت منهمك في الكود التالي (الذي تعدى معي حد الجنون ..!! أكثر من ساعة ونصف وربما ساعتين في هذا الكود)

هو كود مجنون بحق .. حاولت فيه بقدر المستطاع أن أجعله كون مرن يصلح لأي موضوع شبيه بهذا الموضوع (خصوصاً أن هذا الموضوع يتكرر في كثير من الأحيان)

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

الكود المجنون من العيار الثقيل وأرجو أن يبدي الأعضاء أي ملاحظات عليه لتطويره بحيث يصلح لهذه المشكلة أياً كان شكلها وحجمها وأبعادها ...

الكود بالشكل التالي

Sub Transfer_Data_Using_Filter_By_List()
'Author  : YasserKhalil
'Release : 01 - 09 - 2016
'------------------------
    Dim dictPerson As Object, dictSheet As Object, mtx(), isFound As Boolean
    Dim I As Long, v1 As Variant, v2 As Variant, arr As Variant, arrCol As Variant
    Dim rng As Range, arrHeader As Variant
    Dim cnt As Integer, counter As Integer
    Dim Rc As Long, Gc As Long, Bc As Long

    '===========================================================================================
    'Column Number To Be Filtered
    Const iCol As Integer = 5

    'Sheet Name (The Source Sheet)
    Const sSheet As String = "DATA"

    'Data Range Including Header
    Set rng = Sheets(sSheet).Range("A5:E" & Sheets(sSheet).Cells(Rows.Count, iCol).End(xlUp).Row)

    'Row Number For Destination Sheets (5 = Row 5)
    Const destRow As Integer = 5

    'Column Number For Destination Sheets (1 = Column A)
    Const destCol As Integer = 1

    'Column Widths For Output Sheets
    arr = Array(14, 50, 15, 14)

    'Columns Order To Be Copied. So Column 4 In Data Sheet To Be Copied To Column 1 To Destination Sheet
    arrCol = Array(4, 3, 1, 2)

    'Columns Order To Be Copied. So Column 4 In Data Sheet To Be Copied To Column 1 To Destination Sheet
    arrHeader = Array("القيمة", "البيان", "التوجيه المحاسبي", "التاريخ")
    '===========================================================================================

    Application.ScreenUpdating = False
        mtx = rng.Value
    
        Set dictPerson = CreateObject("Scripting.Dictionary")
        For I = 2 To UBound(mtx, 1)
            If Not dictPerson.Exists(mtx(I, iCol)) Then dictPerson.Add mtx(I, iCol), mtx(I, iCol)
        Next I
    
        Set dictSheet = CreateObject("Scripting.Dictionary")
        For I = 1 To Worksheets.Count
            If Not dictSheet.Exists(Worksheets(I).Name) Then dictSheet.Add Worksheets(I).Name, Worksheets(I).Name
        Next I
        dictSheet.Remove (sSheet)
    
        For Each v1 In dictPerson
            isFound = False
            For Each v2 In dictSheet
                If v1 = v2 Then
                    isFound = True
                    Exit For
                End If
            Next v2
    
            If Not isFound Then
                If MsgBox(v1 & " Does Not Exist." & vbCrLf & "Create This Sheet ? ", vbOKCancel) = vbOK Then
                    Worksheets.Add After:=Sheets(sSheet)
                    ActiveSheet.Name = v1
                    ActiveSheet.DisplayRightToLeft = True
                Else
                    dictPerson.Remove v1
                End If
            End If
        Next v1
    
        For Each v1 In dictPerson
            Sheets(v1).Cells.Clear
    
            rng.AutoFilter Field:=iCol, Criteria1:=v1
    
            With rng.Offset(1)
                For counter = LBound(arrCol) To UBound(arrCol)
                    .Columns(arrCol(counter)).SpecialCells(xlCellTypeVisible).Copy
                    Sheets(v1).Cells(destRow + 1, destCol + counter).PasteSpecial xlPasteValues
                    Sheets(v1).Columns(destCol + counter).NumberFormat = .Columns(arrCol(counter)).NumberFormat
                Next counter
    
                Sheets(v1).Cells(destRow, destCol).Resize(1, UBound(arrHeader) + 1).Value = arrHeader
            End With
    
            With rng(1, 1)
                Rc = .Interior.Color Mod 256
                Gc = Int(.Interior.Color / 256) Mod 256
                Bc = Int(Int(.Interior.Color / 256) / 256)
    
                Sheets(v1).Cells(destRow, destCol).Resize(1, UBound(arrHeader) + 1).Interior.Color = RGB(Rc, Gc, Bc)
            End With
    
            With Sheets(v1)
                With .Cells
                    .ReadingOrder = xlRTL
                    .Font.Name = "Arial"
                    .Font.Size = 11
                    .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
                    .RowHeight = 19
                    .ColumnWidth = 9
                End With
    
                With .Cells(destRow - 1, destCol)
                    .Offset(1).CurrentRegion.Borders.Value = 1
                    .Value = v1
                    .Resize(1, UBound(arrHeader) + 1).Interior.Color = vbYellow
                    .Resize(1, UBound(arrHeader) + 1).HorizontalAlignment = xlCenterAcrossSelection
                End With
    
                With .Rows(destRow - 1).Resize(2)
                    .RowHeight = 25
                    .Font.Bold = True
                    .Font.Size = 13
                End With
    
                For cnt = LBound(arr) To UBound(arr)
                    .Columns(destCol + cnt).ColumnWidth = arr(cnt)
                Next cnt
    
                Application.Goto .Range("A1")
            End With
        Next v1
    
        Application.Goto Sheets(sSheet).Range("A1")
        rng.AutoFilter
        Application.CutCopyMode = False
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

فمت بوضع التعليقات باللغة الإنجليزية (معلش تعود مش أكتر)

سأقوم بشرحها لمن يهمه الأمر

أول سطر في التعليق يتعلق برقم العمود الذي يحتوي على القيم التي سيتم فلترتها

السطر التالي يكتب اسم ورقة العمل التي تحتوي على البيانات (الورقة الرئيسية)

السطر التالي نطاق البيانات المراد العمل عليها

السطر التالي رقم الصف المراد وضع البيانات فيه

السطر التالي رقم العمود المراد وضع البيانات فيه .. مثال لو أردنا وضع البيانات في الخلية H3 هذا يعني أن رقم الصف هو 3 ورقم العمود هو 8

السطر التالي عرض الأعمدة في المخرجات ..بما أننا تعاملنا في المخرجات مع 4 أعمدة فيكتب 4 أرقام ..يمكنك ببساطة زيادة أو نقصان العدد

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

المهم هنا الرقم 4 هو رابع عمود في ورقة البيانات ، والرقم 3 هو ثالث عمود في ورقة البيانات ، والرقم 1 أول عمود في ورقة البيانات ، والرقم 2 هو ثاني عمود في ورقة البيانات ، وسيتم ترحيلهم بنفس الترتيب إلى الأوراق الجديدة

السطر التالي هو خاص بالعناوين التي ستوضع في الأوراق الأخرى والتي سيتم ترحيل البيانات إليها ، وقد قمت بذلك أيضاً لأنني لاحظت أن هناك تغيير في العناوين (العمود "مدين" يسمى في المخرجات باسم "القيمة")

 

المهم الأربعة سطور الأخيرة يجب أن يكون كل منها محتوي على 4 عناصر حسب عدد الأعمدة المطلوبة في المخرجات

أسأل الله العظيم أن يكون الكود مفيد لكم وأعتذر عن الإطالة .. ولكن كان لابد من التوضيح التام لما هو مهم في الكود لتتمكنوا من استخدامه بسهولة ويسر ..

لتجربة الكود بشكل أعمق اختر في الخلية E12 ايصال تسوية ، وهي ورقة عمل غير موجودة لتشاهد ورقة العمل وهي تنشأ وتوضع فيها البيانات .. ولك الحرية في تلك النقطة (لك أن تنشيء ورقة العمل أو تلغي ... لابد أن يكون هناك مرونة)

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

 

رابط الملف المرفق من هنا

[محمد السباعي]

الاستاذ  المحترم / ياسر خليل ابو البراء 

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

اولا أعتذر عن الرد يوم الخميس نظرا لان الدوم ينتهي الساعة الثانية بعد الظهر وهو دوام واحد يوم الخميس

ثانيا بخصوص كود الترحيل نحمد الله و نشكره علي نعمة التي لاتعد و تحصى وله الثناء كله و له الحمد كله أهل الثناء و الفضل 

ثم الشكر للاستاذي و معلمي الاستاذ / ياسر خليل ابو البراء الذي أظن و الله اعلم  ان هذا الكودمنة من الله لاهل هذا المنتدي العظيم المتعون المتحاب في الله

وهو كود ليس بمجنون ولكن كود عبقري أكثر من رائع وفيه توفيق من الله و إن شاء الله سينتفع به كثيرا من المستخدمين  وبإذن الله سيكون جبال حسنتات لك ياستاذي و أبشرك بالذي هو خير

اللهم بارك في أستاذي ياسر خليل ابو البراء و بارك له في علمه و عمله ورزقه و أهله و وأولاده و جعلهم ذرية صالحة و بارك في والديه و جزيهم خيرا عن ولدهم ياسر خليل  ووسع له في داره 

وجعله في الجنة مع الصديقين و الشهداء وحسن اولئك رقيق

الحمد لله جربت الكود وهو ممتاز يؤدي المطلوب وزيادة

لكن عند فتح اي شيت اخر مثل مركز للمعلومات (يكون فيه قائمة بالاكود ) او حساب مثل الصندوق و حسابات استاذ اخري ( السولار - البنزين - الطعام - الكهرباء - ........) عند الترحيل يقوم بمسح هذه الشيتات و هي ليس لها علاقة بالكود 

لذا إن سمح وقت إستاذي الاستاذ / ياسر خليل ابو البراء بحل هذه المشكله يكون له الجزاء العظيم 

 

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

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

وجزيت خيراً بمثل ما دعوت لي وزيادة .. وبارك الله فيك على دعائك الطيب المبارك

ومشكور على كلماتك الرقيقة

 

المشكلة التي حدثت معك سببها كلمة واحدة في الكود في هذا السطر

For Each v1 In dictSheet

فبدلاً من الكلمة dictSheet استخدام dictPerson ...

كما تم إضافة سطر في الجزء الشرطي الخاص بإنشاء ورقة عمل ، حتى إذا لم ترغب في إضافة ورقة العمل تحذف من الأوراق المطلوب العمل عليها

 

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

وأي ملحوظة أخرى يرجى الإشارة إليها ..

 

[محمد السباعي]

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

أستاذي المحترم المبدع الاستاذ / ياسير خليل ابو البراء

الحمد لله و الشكر لله جربت التعديل ممتاز و عالج المشكلة 

جزاك الله خير الجزاء و أحسن الله اليك و سامحني أذا كنت شقيت عليك

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

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

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

وكل ما أوتيت من علم بفضل من الله وحده ، وأنا لست إلا سبب جعله الله لكم ليساعدكم على قضاء حوائجكم ...

تقبل تحياتي

[احمد عبدالحليم]

جزاكم الله خيرا اهل هذا الصرح العظيم 

واخص بالذكر استاذنا الغالى ياسر خليل أبو البراء 

يسر الله تعالى طريقك وحياتك 

ورزقك الله تعالى الفردوس الأعلى 

 

 

 

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

الان, أحمد حليم said:

جزاكم الله خيرا اهل هذا الصرح العظيم 

واخص بالذكر استاذنا الغالى ياسر خليل أبو البراء 

يسر الله تعالى طريقك وحياتك 

ورزقك الله تعالى الفردوس الأعلى 

 

 

 

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

ومشكور على دعائك الطيب المبارك ، وأسأل الله العلي القدير أن يجمعنا في الفردوس الأعلى من الجنة

تقبل تحياتي

[السرنجاوى]

بارك الله فيك وعمل ممتاز كنت ابحث عنه كتيرا ولك خالص الشكر والتقدير وكل عام وانتم جميعا بخير

 

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

9 دقائق مضت, السرنجاوى said:

بارك الله فيك وعمل ممتاز كنت ابحث عنه كتيرا ولك خالص الشكر والتقدير وكل عام وانتم جميعا بخير

 

الحمد لله الذي يسر لك الأمور ووجدت ضالتك

وأهلا بك في المنتدى ونورت بين إخوانك .. وإن شاء الله تجد ما يسرك في المنتدى

تقبل تحياتي

[احمد الحاوي]

استاذنا القدير والاخ العزيز ابو البراء ... ملك الابداع كما عودتنا دائما ...تحياتي .. وجزاكم الله خيرا 

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

وجزيت خيراً بمثل ما دعوت لنا يا حاوي

وبعدين فينك بقالك فترة مختفي عن الأنظار ..الفيس واخدك مننا

[الأستاذ / محمد الدسوقى]

أستاذى ومعلمى الفاضل الأستاذ / ياسر خليل أبوالبراء

نحمد الله تعالى أن وهبنا عبقرى مثلك فى هذا الصرح التعليمى العظيم

كما نساله تعالى أن يديم عليك الصحة والعافية ويزيدك علمًا نافعا كما تنفع به غيرك دائما

وفقك الله إلى كل خير وإبددددددددددددددددددددددددددددددداع

 

[حسام ميلكانا]

اخى الفاضل واستاذنا الكبير

ياسر خليل اجمل تحية ليك جعلك الله من سكان الجنة  ان شاء الله

وممكن لو الواحد حب يغير فى الشيط حسب احتياجاتة ازاى يغير فى القائمة وهل لو غيرت فى الاسماء الكود ها يقبلها

وربنا يجزيك خير ويباركلك فى اولادك وفى صحتك

وشكرا

[جلال الجمال_ابو أدهم]

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

اخى الفاضل ما شاء الله عليك

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

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

محمد السوقي وحسام ميلكانا وجلال الجمال

مشكور على كلماتكم الرقيقة ودعائكم الطيب ..

الأخ حسام عوداً حميداً .. ولعل غيابك عن المنتدى خير إن شاء الله

وبعدين جرب في الكود واشتغل على ملف وشوف هيعمل معك ايه .. معاك الكود ومعاك الشرح (طبق خطوة خطوة وشوف النتائج)

[حسام ميلكانا]

اخى الكريم العزيز الى قلوب الملايين / ياسر خليل ابو البراء

ربنا يبارك فى عمرك

انت بتصعبها عليا وعلى  كلا انا ها حاول وهتابع التعليمات زى توجيهاتك وربنا يقوينا

لان الموضوع مش ساهل والوقت ضيق جدا

وشكرا ليك اخى الكريم

 

 

[الأستاذ / محمد الدسوقى]

أستاذى ومعلمى الفاضل الأستاذ / ياسر خليل أبوالبراء

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

أنا جربت أعمل هذا الترحيل عن طريق المعادلات فى كل صفحة ترحيل على حدة ـ كما هو مطلوب

كما يوجد صفحة إجمالية باسم (Mohamed EL_Desoky ) تحتوى على قائمة منسدلة نختار منها البيان المراد ترحيله، فيتم المطلوب ، ... وهكذا

مع خالص تحياتى

Transfer Data To Proper Sheets Using Filter Method YasserKhalil معدل.rar

[محمد السباعي]

الاستاذ المحترم  / محمد الدسوقي 

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

اللهم بارك مجهود ممتاز و حل رائع ينم عن امكانيات عالية في الاكسيل جعلك الله عون للمشتركين في هذا المنتدا العظيم ( منتدا اوفيسنا ) 

بارك الله في جميع المنتمين الي هذا الصرح الرائع

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

أخي العزيز محمد السوقي

بسم الله ما شاء الله حل رائع وممتاز جداً جداً .. أيوا كدا ورينا الإبداع ..

عايز بس أنبهك إلى أن كثرة استخدام معادلات الصفيف تثقل الملف بشكل كبير .. لن تلاحظ الأمر لأن حجم البيانات بالملف صغير ، ولكن إذا كان حجم البيانات ضخم ستجد معاناة كبيرة في التعامل مع الملف .. كما أن للأكواد أفضلية في هذه النقطة ، فلها الأفضلية في كونها قادرة على إنشاء ورقة عمل غير موجودة في حالة لو البيان ليس له ورقة عمل مسبقاً

عموماً عمل رائع وأعجبني كثيراً .. جزاكم الله خيراً أخي الغالي محمد الدسوقي

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

 

[الأستاذ / محمد الدسوقى]

أستاذى ومعلمى الفاضل الأستاذ / ياسر خليل أبوالبراء

شكرًا جزيلا على كلماتك الرقيقة الرقراقة التى تحتوى فى طياتها على التشجيع

فهذا وسام على صدرى اعتز به دائمًا

وتقبل وافر احترامى

[semsem564]

جزاك الله خير استاذ ياسر خليل على ما تقدمة من علم

لاحظت خطأ على الكود وهو اذا قمت بتعديل توجية فرعي على سبيل المثال جعلنا كل التوجية (الايصالات) سنلاحظ بان التعديل ظهر ببند الايصالات بالفعل ولكن لم يحذف من العناصر الاخري

ايضا ارجو توضيح كيفية زيادة اعمدة اضافية

 

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

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

بالنسبة لزيادة عدد الأعمدة راجع الشرح في المشاركة ستجد تفاصيل .. بخصوص حذف العناصر الأخرى .. يمكن ببساطة حذف أوراق العمل قبل بدء التعامل مع الكود
 .. لأن الكود يقوم بإنشاء أوراق العمل في حالة عدم وجودها .. يعني وجود ورقة العمل زي عدمها .. والأمر سيان وفيه مرونة