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

[حاتم عيسى]

هذا الكود من إعداد الأستاذ المحترم : سليم حاصبيا

وهو يعمل بكفاءة عالية في نفس الملف ولكن عند نقله في ملف العمل النهائي يعطي رسالة الخطأ التالية

 

وعند الضغط على كلمة Debug

يظهر الخطا هنا في الكود

فما الحل بالله عليكم .

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

الورقة محمية بكلمة سر

بجب ازالة الجماية عنها

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

 

 

[abouelhassan]

مشكور جدا استاذ سليم روائع

بعد اذن حضرتك استاذ سليم

كان لدى من خلال الابحار بمواضيع حضرتك كود رائع

يقوم بنفس المهمة بس مش عارف الخلل فين هل بالامكان الاطلاع

واين اضع الكود مابين  ws.unprotect 123

            ws.UsedRange.Value = ws.UsedRange.Value

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

 Dim ws          As Worksheet
        For Each ws In ActiveWorkbook.Worksheets
            ws.Unprotect 123
                ws.UsedRange.Value = ws.UsedRange.Value
            ws.Protect 123
        Next ws

شكر وتقدير واحترام من اخيك

[حاتم عيسى]

السادة الأفاضل تم تخفيف حجم الملف الأصلي الذي يتم العمل عليه حتى يسهل رفعة

الرجا من سيادتكم التكرم بحل المشكلة التي تواجهني عند ترحيل البيانات إلى الشيتات المختلفة

مرفق صورة الخطأ

 

ثم يتم حذف البيانات بالكامل من صفحة تسجيل الموظفين

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

وشكرا جزيلا لحضراتكم

 

Hatem_Last.xlsm

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

الملف يحنوي على خلايا مدمجة
كتت قد حذرت من ذلك مسبقاً (ولا حياة لمن تنادي)

لذلك ادرج صفاً فارغا (كما في الصورة  الصف رقم5) حتى يتخلص الجدول من هذه الخلايا المدمجة (تم ادراجه)

 وهناك صفحات لا علاقة لها بالأمر مثل "Form1" و "Form2" الخ...يجب استثناء هذه الصفحات من عمل الماكرو بوضعها في  Array  أسميته (array_sheet) ليتم تجاهلها من جانب الماكرو ( الدالة  Check_Up ) 
و كلما اضفت صفحة لا علاقة لها بالماكرو  يحب وضع اسمها في هذا الــ Array

الماكرو المطلوب (بعد ادراج صف فارغ رقم 5 في الصفحة  "تسجيل_الموظفين")

Option Explicit
Dim I%, LR%
Dim t As Worksheet
Dim Spes_sh As Worksheet
Dim Flter_rg As Range
Dim RO%
Dim array_sheet()
Dim Check_Up As Boolean

Sub ADD_Sheets()
Set t = Sheets("تسجيل_الموظفين")

LR = t.Cells(Rows.Count, 2).End(3).Row
If LR < 7 Then Exit Sub
With t
    For I = 7 To LR
        If Not Application.Evaluate("ISREF('" & _
         .Range("B" & I) & "'!A1)") Then
           Sheets.Add(, Sheets(Sheets.Count)).Name = _
         .Range("B" & I)
        End If
    Next
End With
End Sub
'+++++++++++++++++++++++++++
Sub transfer_data()
Application.ScreenUpdating = False
ADD_Sheets
   array_sheet = Array("Form1", "Form2", "Pictures", _
   "تسجيل_الموظفين", "البيانات الرئيسية")

Set t = Sheets("تسجيل_الموظفين")
t.Select
 Set Flter_rg = t.Range("A6").CurrentRegion
For Each Spes_sh In Sheets

Check_Up = IsError(Application.Match(Spes_sh.Name, array_sheet, 0))
   If Check_Up Then
       Spes_sh.Range("A6").CurrentRegion.Clear
        Flter_rg.AutoFilter 2, Spes_sh.Name
        Flter_rg.SpecialCells(12).Copy
        
            With Spes_sh.Range("A6")
              .PasteSpecial (8)
              .PasteSpecial (12)
              .PasteSpecial (4)
            End With
        
        RO = Spes_sh.Cells(Rows.Count, 1).End(3).Row
         If RO > 6 Then
          Spes_sh.Range("A7").Resize(RO - 6).Value = _
          Evaluate("Row(1:" & RO - 6 & ")")
         End If
     End If
Next Spes_sh
t.AutoFilterMode = False
   t.Select
   With Application
     .ScreenUpdating = True
     .CutCopyMode = False
   End With
End Sub

Hatem_Extra.xlsm

[حاتم عيسى]

الأستاذ الفاضل المحترم : سليم حاصبيا

ممكن حضرتك توضح لي أين يتم إدراج صف فارغ على أن يكون الصف رقم 6

لأني جربت ولم تنجح معي وتم حذف كل البيانات الموجودة وتم عمل شيتات جديدة بالأسماء الموجودة في العمود B ولكنه فارغة

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

فقط اجعل الصف الذي قبل بداية عناوين الجدول فارغاً

تم رفع ملف جديد في اخر مشاركة من قبلي (نسخة عن الملف الذي رفعته انت مع تعدبل الماكرو )

 

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

قم باخفاء الصف رقم 5 (حتى لا يكتب فيه اي شيء عن طريق الخطأ وتقع في نفس المشكلة السّابقة)

[حاتم عيسى]

بارك الله في حضرتك أستاذ : سليم حاصبيا

تم تنفيذ ما تفضلتك به علي والملف يعمل بكفاءة بفضل الله ثم بفضل مجهودكم العظيم .

شكرا لحضرتك ولفريق العمل وكل القائمين على المنتدى