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

ياسين ( أبو وسام ) · مايو 24, 2015

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

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

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

()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

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

ياسر خليل أبو البراء · مايو 24, 2015

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

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

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

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

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

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

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

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

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

ياسر خليل أبو البراء · مايو 24, 2015

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

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

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

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

:wink2: :wink2:

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

**۩◊۩ أبو حنين ۩◊۩** · مايو 24, 2015

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

سلمت يداك

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

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

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

ياسر خليل أبو البراء · مايو 25, 2015

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

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

**ا بو سليمان** · مايو 25, 2015

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

ياسر خليل أبو البراء · مايو 25, 2015

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

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

أبو العاصم · مايو 25, 2015

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

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

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

الأول به سجل

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

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

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

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

ياسر خليل أبو البراء · مايو 25, 2015

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

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

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

الأول به سجل

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

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

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

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

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

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

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

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

**محمد حسن المحمد** · مايو 26, 2015

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

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

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

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

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

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

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

تقبل تحياتي

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

ياسر خليل أبو البراء · مايو 26, 2015

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

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

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

تقبل صباحي

**محمد حسن المحمد** · مايو 26, 2015

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

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

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

تقبل صباحي

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

تسجيل الدخول

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

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information