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

[ياسين ( أبو وسام )]

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

 

اسعد الله ايامكم واتمها بالخير 

 

الرجاء المساعدة في اضافة تعديل على كود الترحيل

()Sub TransferData
    Dim WS As Worksheet, SH As Worksheet
    Dim X As Long
    Set WS = Sheets("ترحيل"): Set SH = Sheets("MP LIST")
    X = SH.Cells(Rows.Count, 2).End(3).Row + 1
    Application.ScreenUpdating = False
        With SH
            .Cells(X, 1) = .Cells(X, 1).Row - 2
            .Cells(X, 2).Resize(, 3) = Application.Transpose(WS.Range("G9").Resize(3))
            .Cells(X, 5).Resize(, 7) = Application.Transpose(WS.Range("G14").Resize(7))
            .Cells(X, 12) = WS.Range("G22")
            .Cells(X, 13).Resize(, 5) = Application.Transpose(WS.Range("G24").Resize(5))
            .Cells(X, 18) = WS.Range("I28")
            .Cells(X, 19) = WS.Range("G30")
            .Cells(X, 23) = WS.Range("G32")
            .Cells(X, 27) = WS.Range("G13")
            .Cells(X, 28) = WS.Range("I13")
            .Cells(X, 29) = WS.Range("G44")
            .Cells(X, 30) = WS.Range("H44")
            .Cells(X, 31) = WS.Range("I44")
            .Cells(X, 32) = WS.Range("G47")
            .Cells(X, 33) = WS.Range("H47")
            .Cells(X, 34) = WS.Range("I47")
            .Cells(X, 36).Resize(, 7) = Application.Transpose(WS.Range("G34").Resize(7))
            .Cells(X, 43) = WS.Range("J41")
            .Cells(X, 44) = WS.Range("G49")
        End With
    Application.ScreenUpdating = True
End Sub

1. محو السحل بعد الترحيل.
2. اظهار مسج خطئ حين لا يتم تعبئة كامل المعلومات .
3. مسج اخر عند تعبئة الخلايا بشكل كامل " تم الترحيل ".
4. في حال تم ادراج رقم الموظف في السابق لايتم عملية الترحيل ويظهر مسج " الرجاء التحقق من رقم الموظف ".

 

 

 

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

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

كان من المفترض طبقاً للتوجيهات إرفاق الملف الخاص بالكود

عموماً أنا كنت قد جهزت الملف بالفعل ، وفي انتظار موضوعك الجديد (اعذرني للتقيد بالتوجيهات)

إليك الكود بعد تعديلات جوهرية فيه ليتناسب مع طلبك الجديد

Sub TransferData()
    Dim WS As Worksheet, SH As Worksheet
    Dim X As Long, I As Long, Arr
    Set WS = Sheets("ترحيل"): Set SH = Sheets("MP LIST")
    X = SH.Cells(Rows.Count, 2).End(3).Row + 1
    
    Application.ScreenUpdating = False
        If Not SH.Range("B:B").Find(WS.Range("G9"), , , xlWhole, , False) Is Nothing Then
            MsgBox "تم إدراج رقم الموظف من قبل", vbInformation: Exit Sub
        Else
            Arr = Array("G9", "G10", "G11", "G14", "G15", "G16", "G17", "G18", "G19", "G20", "G22", "G24", "G25", "G26", "G27", "G28", _
                        "I28", "G30", "", "", "", "G32", "", "", "", "G13", "I13", "G44", "H44", "I44", "G47", "H47", "I47", "", "G34", _
                        "G35", "G36", "G37", "G38", "G39", "G40", "J41", "G49")
            For I = LBound(Arr) To UBound(Arr)
                If Arr(I) <> "" Then Arr(I) = WS.Range(Arr(I)).Value
                If IsEmpty(Arr(I)) Then MsgBox "البيانات غير كاملة يرجى إكمال كافة الحقول": Exit Sub
            Next I
            With SH
                .Cells(X, 1) = .Cells(X, 1).Row - 2
                .Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr
            End With
            'WS.Range("G9:J11,G13:H13,I13:J13,G14:J20,G22:J22,G24:J27,G28:J28,G30:J30,G32:J32,G34:J40,G44:J44,G47:J47,G49:J49").ClearContents
            MsgBox "تم الترحيل بنجاح", vbInformation
        End If
    Application.ScreenUpdating = True
End Sub

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

بالنسبة لهذا السطر

'WS.Range("G9:J11,G13:H13,I13:J13,G14:J20,G22:J22,G24:J27,G28:J28,G30:J30,G32:J32,G34:J40,G44:J44,G47:J47,G49:J49").ClearContents

خاص بمسح البيانات بعد الترحيل ..تم وضع تعليق لإلغاء تنفيذه لتجربة الكود

قم بتغيير رقم الموظف لتجربة الكود ..

 

تقبل تحياتي

Transfer Data Using Arrays YasserKhalil.rar

[ياسين ( أبو وسام )]

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

 

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

 

المعذرة ..... من لهفتي وانا اترقب ردك الجميل نسيت ارفاق الملف   .... وتقبل تحياتي

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

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

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

أخي في الله ياسين .. يا سيد الحلوين

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

ومشكور على تحديد أفضل إجابة ليظهر الموضوع مجاب

:wink2:

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

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

الاخ الجليل ياسر خليل

سلمت يداك 

دائما لديك حلول ....لكل ما هو مطروح من الاعضاء

والاهم .دوما ما نجد الاستفاده والتعليم مما تطرحه

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

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

مشكور أخي الحبيب أبو حنين على مرورك العطر وعلى كلماتك الطيبة

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

[ا بو سليمان]

يااااريت تم عمل نسخة مكرره   ويتم اختصار  الى  عمل نموذج  من  صفين فقط   لكي يسهل التطبيق

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

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

سأترك لك المجال لعمل نسخة مصغرة ..لابد لكي تتعلم أن تتعب

[أبو العاصم]

الاستاذ الدكتور ياسر خليل 

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

بمعنى عمل شيتين أخرين 

الأول به سجل 

والثانى به الفورم

وعند إستدعاء اى رقم يمتلىء الفورم ببيانات ذلك الرقم

الرجاء التفضل 

وبالكود وبدون معادلة vlookup

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

الاستاذ الدكتور ياسر خليل 

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

بمعنى عمل شيتين أخرين 

الأول به سجل 

والثانى به الفورم

وعند إستدعاء اى رقم يمتلىء الفورم ببيانات ذلك الرقم

الرجاء التفضل 

وبالكود وبدون معادلة vlookup

أخي الكريم أبو عاصم

كل شيء ممكن بالصبر والمحاولة والإصرار

اطرح فكرتك في موضوع لتجد الحل من الأخوة الأعضاء ..

لا أحبذ تداخل الموضوعات ..أبح الاستقلالية في الموضوعات حتى يتسنى للباحث فيما بعد أن يجد بغيته

[محمد حسن المحمد]

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

كان من المفترض طبقاً للتوجيهات إرفاق الملف الخاص بالكود

عموماً أنا كنت قد جهزت الملف بالفعل ، وفي انتظار موضوعك الجديد (اعذرني للتقيد بالتوجيهات)

إليك الكود بعد تعديلات جوهرية فيه ليتناسب مع طلبك الجديد

Sub TransferData()
    Dim WS As Worksheet, SH As Worksheet
    Dim X As Long, I As Long, Arr
    Set WS = Sheets("ترحيل"): Set SH = Sheets("MP LIST")
    X = SH.Cells(Rows.Count, 2).End(3).Row + 1
    
    Application.ScreenUpdating = False
        If Not SH.Range("B:B").Find(WS.Range("G9"), , , xlWhole, , False) Is Nothing Then
            MsgBox "تم إدراج رقم الموظف من قبل", vbInformation: Exit Sub
        Else
            Arr = Array("G9", "G10", "G11", "G14", "G15", "G16", "G17", "G18", "G19", "G20", "G22", "G24", "G25", "G26", "G27", "G28", _
                        "I28", "G30", "", "", "", "G32", "", "", "", "G13", "I13", "G44", "H44", "I44", "G47", "H47", "I47", "", "G34", _
                        "G35", "G36", "G37", "G38", "G39", "G40", "J41", "G49")
            For I = LBound(Arr) To UBound(Arr)
                If Arr(I) <> "" Then Arr(I) = WS.Range(Arr(I)).Value
                If IsEmpty(Arr(I)) Then MsgBox "البيانات غير كاملة يرجى إكمال كافة الحقول": Exit Sub
            Next I
            With SH
                .Cells(X, 1) = .Cells(X, 1).Row - 2
                .Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr
            End With
            'WS.Range("G9:J11,G13:H13,I13:J13,G14:J20,G22:J22,G24:J27,G28:J28,G30:J30,G32:J32,G34:J40,G44:J44,G47:J47,G49:J49").ClearContents
            MsgBox "تم الترحيل بنجاح", vbInformation
        End If
    Application.ScreenUpdating = True
End Sub

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

بالنسبة لهذا السطر

'WS.Range("G9:J11,G13:H13,I13:J13,G14:J20,G22:J22,G24:J27,G28:J28,G30:J30,G32:J32,G34:J40,G44:J44,G47:J47,G49:J49").ClearContents

خاص بمسح البيانات بعد الترحيل ..تم وضع تعليق لإلغاء تنفيذه لتجربة الكود

قم بتغيير رقم الموظف لتجربة الكود ..

 

تقبل تحياتي

أحاول أن أبدي إعجابي بالمجهود والنتائج الرائعة التي تبدونها فيظهر لي ......هذا؟؟؟؟؟؟!!!!!!!!!!!!!!!!!!!!!!!!. 

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

بارك الله فيك أبو يوسف

تقريباً فيه حد أقصى للإعجابات لليوم الواحد .. وبعدين ولا يهمك أنا عارف اللي عندك ..

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

تقبل صباحي

[محمد حسن المحمد]

بارك الله فيك أبو يوسف

تقريباً فيه حد أقصى للإعجابات لليوم الواحد .. وبعدين ولا يهمك أنا عارف اللي عندك ..

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

تقبل صباحي

السلام عليكم أخي أبو البراء الغالي: الله يسعد جميع أوقاتك صباحها ومساءها...بنور الإيمان