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

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

السلام عليكم

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

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

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

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

 

 

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

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

للرفع

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

للرفع

للرفع

للرفع

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

للرفع

 

[هاني بدر]

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

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

COMMANDBUTTOM 1. ENABLED =FALSE

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

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

تحياتي

[أبو العاصم]

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

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

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

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

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

[هاني بدر]

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

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

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

تحياتي

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

السلام عليكم

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

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

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

 

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

تم تعديل يونيو 16, 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

[طارق محمود]

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

    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

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

السلام عليكم

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

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

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

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

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

[علي الشيخ]

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

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

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 لو مكرر مش هيتم الترحيل

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

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

السلام عليكم

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

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

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

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

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

 

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

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

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

للرفع

للرفع

للرفع

[هاني بدر]

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

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

 

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

I11

ووضع الخلية

G36

 

Sub Transfer()

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

تحياتي

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

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

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

السلام عليكم

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

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

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

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

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

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

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

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

[هاني بدر]

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

اخي الكريم

 

تقبل تحياتي

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