اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

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

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

 

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

 

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

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

  • Like 1
رابط هذا التعليق
شارك

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

 

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

 

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

تم تعديل بواسطه ياسين ( أبو وسام )
  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

:wink2: :wink2:

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

  • Like 1
رابط هذا التعليق
شارك

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

سلمت يداك 

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

الأول به سجل 

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

الأول به سجل 

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

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

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

وبالكود وبدون معادلة 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

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

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

 

تقبل تحياتي

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

post-139362-0-91673200-1432627090_thumb.

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

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

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

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

تقبل صباحي

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

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

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

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

تقبل صباحي

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

  • Like 1
رابط هذا التعليق
شارك

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

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information