ترحيل بيانات مع وضع احتمال لرغبة التكرار وعدم التكرار لاسم المشروع

[وضاح محمد]

الاخوة الاكارم

 

سلام الله عليكم

 

الرجاء مساعدتي في عمل كود vba كما يلي :

 

احتاج الى ترحيل  البيانات التي في المدى من A2:M2  . .الى . . الورقة2  . . . ووضعها بعد اخر صف به بيانات

 

ثم عند  محاوله ادخال بيانات  لمشروع جديد في خليه B2 ومحاولة ترحيل بياناته تكون هناك رساله تنبيهيه "بان اسم المشروع موجود مسبقا هل تريد استبدال البيانات"

 

 فاذا تم اختيار " نعم " يقوم باستبدال البيانات القديمة ويضع بدلا عنها البيانات الجديدة 

 

واذا تم اختيار " لا " فانه يترك البيانات السابقة كما هي ويقوم باضافة البيانات الجديدة بعد  اخر صف به بيانات حتى وان تكرر اسم المشروع

 

واذا امكن اضافة الترقيم التلقائي التسلسلي لاي بيانات جديدة تضاف في العمود A . ورقة2

 

ترحيل بيانات مع عدم تكرار اسم المشروع.rar

 

 

وتقبلوا فائق الاحترام

[وضاح محمد]

الاخوة الاكارم

 

سلام الله عليكم

 

الحمد لله قد تمكنت من عمل كود الترحيل .

 

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

 

وتقبلوا خالص التحية 

 

 

ترحيل بيانات مع الرغبة في تكرار او عدم تكرار اسم المشروع.rar

تم تعديل يونيو 7, 2014 بواسطه وضاح محمد

[رجب جاويش]

السلام عليكم

تفضل أخى

هذا الكود يقوم بعمل اللازم

Sub ragab()
Dim LR As Integer, R As Integer
Dim Rng As Range, cl As Range
'==============================================
Set ws = Sheets("ورقة2")
Set WF = Application.WorksheetFunction
'==============================================
LR = ws.Cells(Rows.Count, 2).End(xlUp).Row
Set Rng = ws.Range("B2:B" & LR)
Application.ScreenUpdating = False
'==============================================
Range("B2:M2").Copy
If WF.CountIf(Rng, [B2]) > 0 Then
    ansr = MsgBox("هذا المشروع موجود بالفعل" & Chr(10) & " " & "اذا كنت تريد إستبدالة اضغط  نعم" _
    & Chr(10) & " " & "وان لم ترد استبداله اضغط  لا", vbYesNo, "مشروع مكرر")
    If ansr = vbYes Then
        R = WF.Match([B2], Rng, 0) + 1
        ws.Range("B" & R).PasteSpecial xlPasteValues
        GoTo 1
    Else
        GoTo 2
    End If
End If
2:
ws.Range("b" & LR + 1).PasteSpecial xlPasteValues
LR = ws.Cells(Rows.Count, 2).End(xlUp).Row
For Each cl In ws.Range("A2:A" & LR)
    cl = cl.Row - 1
Next
1:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[محمود_الشريف]

أخى فى الله

استاذى القدير // رجب جاويش

بارك الله فيكم وجزاكم رب العالمين عنا خيرا

نسأل الله لكم أن يحفظكم من كل سوء بسر حفظه لكتابه الحكيم

تقبل منى وافر الاحترام والتقدير

[وضاح محمد]

الاستاذ القدير / رجب جاويش

 

بارك الله فيك .نعم هذا هو المطلوب بعينه ... 

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

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

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

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

بارك الله فيك.... وتوفاك مسلما ...والحقك بالصالحين . . .

 

 

وتقبل مني خالص التحية والتقدير والامتنان ...

[عادل ابوزيد]

الاستاذ الفاضل المحترم رجب جاويش

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

اسمحى بطلب لتطوير العمل

وهو عندما يكون اسم المشروع مكرر اكثر من مره وعند ادخاله مره اخرى ويراد استبدال الاخير يقوم الكود  باستبدال اول ادخال للشركه

فهل يمكن اجراء تعديل بحيث يتم اختيار البيانات التى يمكن استبدالها

تقبل منى كل الحب والتقير لشخصكم الكريم