أضافه على كود ترحيل لعدم تكرار الترحيل

**۩◊۩ أبو حنين ۩◊۩** · يونيو 10, 2015

السلام عليكم

الاخوة الكرام كل عام وانتم بكل خير

ارجو المساعدده فى اضافه على كود

اولا الكود للاخ الكريم ياسر خليل ... اكرمة الله بكل الخير

المطلوب اضافة الغرض منها عدم تكرار الترحيل للبيانات المرحله اذا تم اضغط على رز الترحيل اكثر من مرة

Sub Transfer1()
Application.ScreenUpdating = False
    On Error Resume Next
    Dim Cell As Range, T As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long

    Set WS = Sheets("1")
    LR = WS.Cells(35, 3).End(xlUp).Row
    T = WS.Range("A3").Value

    Application.ScreenUpdating = False
    WS.Unprotect "2191612"
        If Not IsEmpty(WS.Range("c6")) Then
            With Sheets(T)
                .Unprotect "2191612"
                LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1

                WS.Range("B6:G" & LR).Copy
                .Cells(LRT, 2).PasteSpecial xlPasteValues
                .Protect "2191612"
            End With

            Answer = MsgBox("تم ترحل البيانات .....هل تريد أن مسح البيانات المرحلة؟", vbYesNo + vbQuestion)
            If Answer = vbYes Then
                Sheets("1").Activate
                Sheets("1").Range("A3,C6:C35,F6:G35").Select
                Selection.ClearContents
            Else
                MsgBox "!! لم يتم الحذف"
            End If
            Sheets("1").Select
            ActiveWindow.SmallScroll Down:=-12
            Range("A3,C6").Select
        Else
            MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub
        End If
    WS.Protect "2191612"
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

**۩◊۩ أبو حنين ۩◊۩** · يونيو 10, 2015

للرفع

**۩◊۩ أبو حنين ۩◊۩** · يونيو 11, 2015

للرفع

**۩◊۩ أبو حنين ۩◊۩** · يونيو 11, 2015

للرفع

هاني بدر · يونيو 11, 2015

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

هناك طرق كثيرة واسهلها هو ان تقوم بتعطيل عمل الكوماند المسئول عن الترحيل

COMMANDBUTTOM 1. ENABLED =FALSE

,وذلك في نهاية كود الترحيل او في الموقع الذي يلائم اختيارات الترحيل

ثم اعادة تشغيله عند البدء بتسجيل بيانات جديدة

تحياتي

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

والله أخ هانى بدر

أنا تعبت جدا من بعض الاكواد وبعض الحلول

ومحتاج خبير برمجة وخبير محاسبة

لمساعدتى واعطائى المقترحات

فهل وقتك مناسب

هاني بدر · يونيو 12, 2015

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

اخي الكريم انا تحت امرك في المحاسبة

اما ما يخص البرمجة فلا يفتى ولدينا الف مالك في المدينة

تحياتي

**۩◊۩ أبو حنين ۩◊۩** · يونيو 16, 2015

السلام عليكم

الاخوة الكرام هل من حل لعدم تكرار الترحيل

عند تنفيذ الكود يتم كتابة تم الترحيل امام الخلايا التى تم ترحيلها فى العمود H

وذلك يكون شرط لعدم الترحيل .... اى عند وجود كلمه تم الترحيل فى العمود H

مستحقات العاملين والاستعاضة.rar

تم تعديل يونيو 16, 2015 بواسطه ۩◊۩ أبو حنين ۩◊۩

**۩◊۩ أبو حنين ۩◊۩** · يونيو 17, 2015

للرفع

**طارق محمود** · يونيو 17, 2015

السلام عليكم

أخي العزيز

جرب التعديل التالي ، فأنا لم اجربه

Sub Transfer()
  Application.ScreenUpdating = False
    On Error Resume Next
    Dim Cell As Range, T As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long


    Set WS = Sheets("1")
    LR = WS.Cells(35, 3).End(xlUp).Row
    nR = 6
10   If Cells(nR, "H").Value = "تم الترحيل" Then nR = nR + 1: GoTo 10
    If nR > LR Then MsgBox "لن يتم الترحيل : برجاء ضبط العمود إتش": Exit Sub
    T = WS.Range("A3").Value


    Application.ScreenUpdating = False
    WS.Unprotect "2191612"
        If Not IsEmpty(WS.Range("C6")) Then
            With Sheets(T)
                .Unprotect "2191612"
                LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                WS.Range("B" & nR & ":G" & LR).Copy
                .Cells(LRT, 2).PasteSpecial xlPasteValues
                .Protect "2191612"
             End With
            WS.[H6].Value = "تم الترحيل"
            WS.Range("H6:H" & LR).FillDown
            Sheets("1").Select
            ActiveWindow.SmallScroll Down:=-12
            Range("A3,C6").Select
        Else
            MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub
        End If
    WS.Protect "2191612"
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

**طارق محمود** · يونيو 17, 2015

أنا أضفت في الجزء العلوي

    nR = 6
10   If Cells(nR, "H").Value = "تم الترحيل" Then nR = nR + 1: GoTo 10
    If nR > LR Then MsgBox "لن يتم الترحيل : برجاء ضبط العمود إتش": Exit Sub

وأضفت في الجزء السفلي بعد End With

            WS.[H6].Value = "تم الترحيل"
            WS.Range("H6:H" & LR).FillDown

**۩◊۩ أبو حنين ۩◊۩** · يونيو 18, 2015

السلام عليكم

اهى الكريم طارق

جزاك الله خيرا على اهتمامك

اخى الحبييب طارف

تم تجربة الكود الا انه مستمر فى الترحيل .... ولا يظهر اى شئ فى العمود h

الترحيل يتكرر بصوره مستمره غد استخدام الكود

**علي الشيخ** · يونيو 18, 2015

السلام عليكم أخي الكريم

حضرتك جرب الكود كالتالي

Sub Transfer()
  Application.ScreenUpdating = False
    On Error Resume Next
    Dim Cell As Range, T As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long

    Set WS = Sheets("1")
    LR = WS.Cells(35, 3).End(xlUp).Row
    T = WS.Range("A3").Value

    Application.ScreenUpdating = False
    WS.Unprotect "2191612"
        If Not IsEmpty(WS.Range("C6")) Then
            With Sheets(T)
                .Unprotect "2191612"
                LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                
                For r = 3 To LRT
        If Sheets("Medi. Kha").Cells(r, 3) = Range("C6") Then MsgBox "This record is already exist, No shift will done": Exit Sub
    Next
                WS.Range("B6:G" & LR).Copy
                .Cells(LRT, 2).PasteSpecial xlPasteValues
                .Protect "2191612"
            End With
              
              Sheets("1").Select
            ActiveWindow.SmallScroll Down:=-12
            Range("A3,C6").Select
        Else
            MsgBox "ÇáÎáíÉ ÇáãÍÏÏÉ ÝÇÑÛÉ áÐÇ áä íÊã ÊäÝíÐ ÇáßæÏ": Exit Sub
        End If
    WS.Protect "2191612"
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

الجزء الذي تم إضافته هو

 For r = 3 To LRT
        If Sheets("Medi. Kha").Cells(r, 3) = Range("C6") Then MsgBox "This record is already exist, No shift will done": Exit Sub
    Next

تم الإعتماد على رقم الـ PR/NO لو مكرر مش هيتم الترحيل

ان شاء الله يكون ع الاقل قريب من المطلوب

**۩◊۩ أبو حنين ۩◊۩** · يونيو 18, 2015

السلام عليكم

اخى العزيز على الشيخ

جزاك الله كل الخير على المشاركه

الا ان المطلوب عدم تكرار عمليه الترحيل

لان المرحل علاج ومتعلقات ماليه لاشخاص والاكيد ان الاشخاص يكرر له علاج ومستحقات

لا يمكن جعل الشرط رقم العامل ...

فكره الاخ طارق هى المطلوبه لانها توضح لى ان البيانات تم ترحيلها طالما فى العمود H كلمه تم الترحيل

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

**۩◊۩ أبو حنين ۩◊۩** · يونيو 19, 2015

للرفع

هاني بدر · يونيو 19, 2015

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

اخي الكريم جرب المرفق لعله يفي بالغرض

ويمكن استبدال شرط الخلية

I11

ووضع الخلية

G36

Sub Transfer()

If Sheets("1").[i11] = 0 Then
MsgBox "عفواً لا توجد بيانات للترحيل", vbInformation, "بيانات غير مكتملة "
Else
TEST_TRANSFER
End If
End Sub

تحياتي

مستحقات العاملين والاستعاضة.rar

تم تعديل يونيو 19, 2015 بواسطه هاني بدر

**۩◊۩ أبو حنين ۩◊۩** · يونيو 19, 2015

السلام عليكم

الاخ الكريم هانى بدر

كل عام وانت بكل خير واسال الله العظيم كل الخير لك فى شهر رمضان الكريم ولجميع المسلمين

الاخ الكريم..... الحل المقترح حل قد يصل الى المطلوب

الا انه بعد مراجعه كود الاخ الكبير والمعلم الجليل طارق محمود تم الامر بصورة جيده

جزا الله كل الخير للاخ الكريم طارق

جزا الله كل الخير للاخ الكريم هانى

وكل عام وانتم بالف خير

تم تعديل يونيو 20, 2015 بواسطه ۩◊۩ أبو حنين ۩◊۩

هاني بدر · يونيو 19, 2015

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

اخي الكريم

تقبل تحياتي

تم تعديل يونيو 19, 2015 بواسطه هاني بدر

تسجيل الدخول

أضافه على كود ترحيل لعدم تكرار الترحيل

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

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

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

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

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

هاني بدر

أبو العاصم

هاني بدر

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

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

طارق محمود

طارق محمود

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

علي الشيخ

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

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

هاني بدر

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

هاني بدر

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information