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

[حاتم عيسى]

بسم الله الرحمن الرحيم

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

علما بأن كلمة مرور الحماية هى ( 123 )

وشكرا لكم جميعا

Option Base 1

Sub Transfer_Data()
'
Dim Sh_Master As Worksheet
Dim Rng As Range
Dim Arr()
Application.ScreenUpdating = False
'======================================================================================
Set Sh_Master = Sheets("الرئيسية")
For Each Sh In Sheets
    If Sh.Name <> Sh_Master.Name Then
        Sh.Range("B7:H" & Rows.Count).ClearContents
    End If
Next
End_Row = Sh_Master.Cells(Rows.Count, "C").End(xlUp).Row
Set Rng = Sh_Master.Range("A6:N" & End_Row)
Arr = Rng
'======================================================================================
For Row = 2 To UBound(Arr)
    For Col = 7 To 12
        If Arr(Row, Col) = 1 Then
            ShName = Arr(1, Col)
            End_Row = Sheets(ShName).Cells(Rows.Count, "C").End(xlUp).Row + 1
            Set Rng = Range(Sh_Master.Cells(Row + 5, "B"), Sh_Master.Cells(Row + 5, "F"))
            Rng.Copy Sheets(ShName).Range("B" & End_Row)
            Sheets(ShName).Range("G" & End_Row) = Arr(1, Col)
            '==============================
            Sheets(ShName).Range("H" & End_Row) = Sh_Master.Cells(Row + 5, "N") - 1
            ' OR
            '            Sheets(ShName).Range("H" & End_Row) = "عنده مواد تالية"
            '==============================
        End If
    Next
Next
'======================================================================================
    Application.ScreenUpdating = True
'
End Sub

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

أخي الكريم حاتم عيسى

يرجى دائماً إرفاق ملف للعمل عليه وتيسير تقديم المساعدة المطلوبة

عموماً جرب التعديل التالي عله يفي بالغرض

Sub Transfer_Data()
    Dim Sh_Master As Worksheet
    Dim Rng As Range
    Dim Arr()

    Application.ScreenUpdating = False
        Set Sh_Master = Sheets("الرئيسية")
    
        For Each sh In Sheets
            If sh.Name <> Sh_Master.Name Then
                sh.Unprotect 123
                sh.Range("B7:H" & Rows.Count).ClearContents
            End If
        Next sh
    
        End_Row = Sh_Master.Cells(Rows.Count, "C").End(xlUp).Row
        Set Rng = Sh_Master.Range("A6:N" & End_Row)
        Arr = Rng
    
        For Row = 2 To UBound(Arr)
            For Col = 7 To 12
                If Arr(Row, Col) = 1 Then
                    ShName = Arr(1, Col)
                    End_Row = Sheets(ShName).Cells(Rows.Count, "C").End(xlUp).Row + 1
                    Set Rng = Range(Sh_Master.Cells(Row + 5, "B"), Sh_Master.Cells(Row + 5, "F"))
                    Rng.Copy Sheets(ShName).Range("B" & End_Row)
                    Sheets(ShName).Range("G" & End_Row) = Arr(1, Col)
                    '==============================
                    Sheets(ShName).Range("H" & End_Row) = Sh_Master.Cells(Row + 5, "N") - 1
                    ' OR
                    '            Sheets(ShName).Range("H" & End_Row) = "عنده مواد تالية"
                    '==============================
                End If
            Next Col
        Next Row
    
        For Each sh In Sheets
            If sh.Name <> Sh_Master.Name Then
                sh.Protect 123
            End If
        Next sh
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

تقبل تحياتي

[حاتم عيسى]

أستاذي الفاضل المحترم الخلوق : ياسر خليل أبو البراء

تحيى طيبة من عند الله ... وبعد

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

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

ولسيادتكم جزيل الشكر والتقدير

 

الدور الثاني.rar

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

أخي الكريم حاتم

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

 

[حاتم عيسى]

أستاذي الفاضل المحترم الخلوق : ياسر خليل أبو البراء

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

[omar elhosseini]

 

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

انت هنا تعرض كودد الملف

Omar_2.rar

مع ملف اوراقة المعنية محمية

كان من الواجب عرض كود الملف

Omar_3.rar

لا يجوز هذا الخلط

وها هو كود الملف

Omar_3.rar

 

Option Base 1

Sub Transfer_Data()
'
Dim Sh_Master As Worksheet
Dim Rng As Range
Dim Arr()
Application.ScreenUpdating = False
'======================================================================================
UnProtect_Me
Set Sh_Master = Sheets("الرئيسية")
For Each Sh In Sheets
    If Sh.Name <> Sh_Master.Name Then
        Sh.Range("A7:H" & Rows.Count).ClearContents
    End If
Next
End_Row = Sh_Master.Cells(Rows.Count, "C").End(xlUp).Row
Set Rng = Sh_Master.Range("A6:N" & End_Row)
Arr = Rng
'======================================================================================
For Row = 2 To UBound(Arr)
    For Col = 7 To 12
        If Arr(Row, Col) = 1 Then
            ShName = Arr(1, Col)
            End_Row = Sheets(ShName).Cells(Rows.Count, "C").End(xlUp).Row + 1
            Set Rng = Range(Sh_Master.Cells(Row + 5, "A"), Sh_Master.Cells(Row + 5, "F"))
            Rng.Copy Sheets(ShName).Range("A" & End_Row)
            Sheets(ShName).Range("G" & End_Row) = Arr(1, Col)
            '==============================
            Sheets(ShName).Range("H" & End_Row) = Sh_Master.Cells(Row + 5, "N") - 1
            ' OR
            '            Sheets(ShName).Range("H" & End_Row) = "عنده مواد ثانية"
            '==============================
        End If
    Next
Next
'======================================================================================
Protect_Me
Application.ScreenUpdating = True
'
End Sub
Sub Protect_Me()
'
Dim Sh As Worksheet
'
Pass = "123"
For Each Sh In Sheets
    If Sh.Name <> ActiveSheet.Name Then
        Sh.Protect Password:=Pass
    End If
Next
'
End Sub

Sub UnProtect_Me()
'
Dim Sh As Worksheet
'
Pass = "123"
For Each Sh In Sheets
    Sh.Unprotect Password:=Pass
Next
'
End Sub

 

تم تعديل أغسطس 6, 2016 بواسطه عمر الحسيني