تعديل وضبط كود اضافه

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

السلام عليكم
الساده الكرام ... اكرمك الله بفضله
ارجو المساعده فى تصحيح ذلك الكود

هذا الكود يعمل على اضافه واحد للخلايا الموضحه

Sub addition_1()
Dim ER, R
ER = ActiveSheet.UsedRange.Rows.Count
For R = 8 To ER
If WorksheetFunction.IsNumber(Cells(R, 7)) = True And _
Cells(R, 7) <> 0 Then Cells(R, 7) = Cells(R, 7) + 1
If WorksheetFunction.IsNumber(Cells(R, 21)) = True And _
Cells(R, 21) <> 0 Then Cells(R, 21) = Cells(R, 21) + 1
Next R
End Sub

اريد ان اضيف اكثر من شيت بدلا من ActiveSheet

وليكن شيت الادارية والاتصالات والمعمل وهكذا
لكى يعمل الكود مره واحده على جميع الشيتات المذكرة
جزاك الله خيرا

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

استاذ ابو حنين جرّب هذا الكود

Sub add_one
lr = Cells(Rows.Count, 7).End(xlUp).Row
For r = 8 To lr
((y = Application.WorksheetFunction.IsNumber(Cells(7, 7
((y1 = Application.WorksheetFunction.IsNumber(Cells(21, 7

If y And y1 And Cells(lr, 7) > 0 _
And Cells(lr, 21) > 0 Then
Cells(lr, 7) = Cells(lr, 7) + 1: Cells(lr, 21) = Cells(lr, 21) + 1
End If
Next

End Sub

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

السلام عليكم

الاخ  سليم حاصبيا

الكود  لا يعمل

اذ انه يعطى لون احمد على السطرين

Sub add_one
lr = Cells(Rows.Count, 7).End(xlUp).Row
For r = 8 To lr
((y = Application.WorksheetFunction.IsNumber(Cells(7, 7
((y1 = Application.WorksheetFunction.IsNumber(Cells(21, 7

 

لا اعلم لماذا

وبعد تعديل الكود بهذا الشكل

لا يعمل

لا اجد اى تغير

 

Sub add_one()
lr = Cells(Rows.Count, 7).End(xlUp).Row
For R = 8 To lr
y = Application.WorksheetFunction.IsNumber(Cells(7, 7))
y1 = Application.WorksheetFunction.IsNumber(Cells(21, 7))
If y And y1 And Cells(lr, 7) > 0 _
And Cells(lr, 21) > 0 Then
Cells(lr, 7) = Cells(lr, 7) + 1: Cells(lr, 21) = Cells(lr, 21) + 1
End If
Next

End Sub

 

 

 

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

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

اليك الملف مع الكود (معدلاً بعض الشيء)

ابو حنين جمع اخر صف.rar

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

السلام عليكم

الاخ العزيز  سليم

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

ثانيا

بعتزر لعدم ايصال المطلوب بوضوح

الكود المرفق يعمل على   ActiveSheet

الذى اريده

ان استبدل  ActiveSheet باكثر من شيت يتم ادخالهم 

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

بدلا من كونى ادخل كل صفحه  واقوم بتفعيل الكود

الكود يعمل بصوره جيده

الا انى اريد استبدال   ActiveSheet  بالشيتات التى اريدها

مثل الاداريه و الاتصالات  والمعل و الهندسيه والصيانه والطبيه

ارجو ان تكون الصوره واضحه

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

 

.Sub addition_1()
Dim ER, R
ER = ActiveSheet.UsedRange.Rows.Count
For R = 8 To ER
If WorksheetFunction.IsNumber(Cells(R, 7)) = True And _
Cells(R, 7) <> 0 Then Cells(R, 7) = Cells(R, 7) + 1
If WorksheetFunction.IsNumber(Cells(R, 21)) = True And _
Cells(R, 21) <> 0 Then Cells(R, 21) = Cells(R, 21) + 1
Next R
End Sub
 

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

 جرب هذا الشيء

'تضيف الى الكود ما يلي
    Dim MyArray As Variant
        'تستطيع ان تضيف ما تشاء  MyArray = Array("Sheet1", "Sheet2", "Sheet3") 
    Sheets(MyArray).Select
    For Each Sheet In MyArray
    '##################################################
   ' تضع الكود هنا
    '###################################################
    
    Next
    
End Sub

[رجب جاويش]

بعد إذن أخى الحبيب / سليم

هذا التعديل لاثراء الموضوع

Sub addition_1()
Dim ER, R
For i = 1 To Sheets.Count
Sheets(i).Select
ER = ActiveSheet.UsedRange.Rows.Count
For R = 8 To ER
If WorksheetFunction.IsNumber(Cells(R, 7)) = True And _
Cells(R, 7) <> 0 Then Cells(R, 7) = Cells(R, 7) + 1
If WorksheetFunction.IsNumber(Cells(R, 21)) = True And _
Cells(R, 21) <> 0 Then Cells(R, 21) = Cells(R, 21) + 1
Next R
Next i
Sheet1.Select
End Sub

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

السلام عليكم

اخى الحبيب  سليم حاصبيا

سلمت يداك .. وشاكر لك على اهتمامك لم اتمكن من ضبط الكود ... برجاء ارسال الكود كامل .. جزاك الله حيرا

اخى الحبيب  رجب جاويش

سلمت يداك  ... الا ان الكود لا يعمل الا فى الورقه التى اقف بداخلها بها  ... كما انه لو عمل لا اريدة ان يعمل فى جميع الاوراق

اريد ان يعمل على ورق محدد

هل من حل

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

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

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

استاذ ابو حنين 

لك هذا لكن علي ان أذهب الى العمل الان

انشاء الله بعد الظهر سأحاول ان افعل شيئاً

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

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

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

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

هذا الكود يعمل على كل الأوراق 

اذا اردت ان يعمل على بعضها سأرسل لك التعديل

جمع اخر صف معدل ابو حنين.rar

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

تعديل الكود بحيث يعمل على اوراق محددة

اخي ابو حنين/ يجب ان تزيل الفاصلة من جانب السطر if اخضر اللون وتحدد مكان علامات الاستفهام ارقام الأوراق المستثناة

Sub add_one()
Dim sh As Worksheet
Application.ScreenUpdating = False
For i = 1 To Sheets.Count
'If i = ??  or i=?? or i=?? or i=??then go to 1
Sheets(i).Select

lr = Cells(Rows.Count, 7).End(xlUp).Row

y = Application.WorksheetFunction.IsNumber(Cells(7, 7))
y1 = Application.WorksheetFunction.IsNumber(Cells(21, 7))

If y And y1 And Cells(lr, 7) > 0 _
And Cells(lr, 21) > 0 Then
Application.EnableEvents = False
Cells(lr, 7) = Cells(lr, 7) + 1: Cells(lr, 21) = Cells(lr, 21) + 1
Application.EnableEvents = True
End If
1:
Next
Sheets(1).Select
Application.ScreenUpdating = True
End Sub

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

للرفع

[رجب جاويش]

أخى الفاضل / أبو حنين

برجاء ارفاق ملف يحتوى على نموذج لما تريد

مع توضيح عدد وأسماء الأوراق التى تريد أستثناءها عند تنفيذ الكود

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

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

السلام عليكم الاخوة الافاضل

اعلم انى اثقل عليكم واعلم مدى انشغالكم

فتقبلوا عزرى

الكود المراد هو كود

Sub addition

 

اسم المستخدم الدعم الفنى كلمه المرور 111

المراد ان يعمل الكود عند الضغط على الزر على السيتات الاتىى اسمائها مره واحده

الادارية

الاتصالات

الغاز

المعمل

الطبية

الهندسية

الامن الصتاعى

المهمات

الانتاج

المعالجة

الصيانة

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

ترقية المستخدم.rar

[شوقي ربيع]

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

Option Explicit
Sub addition_1()
Dim shN As String
Dim r As Integer, i As Integer
Dim lr As Long
Dim y, y1


    For i = 1 To Worksheets.Count
    shN =Sheets(i).Name
    If shN = "الادارية" Or _
       shN = "الاتصالات" Or _
       shN = "الغاز" Or _
       shN = "المعمل" Or _
       shN = "الطبية" Or _
       shN = "الهندسية" Or _
       shN = "الامن الصتاعى" Or _
       shN = "المهمات" Or _
       shN = "الانتاج" Or _
       shN = "المعالجة" Or _
       shN = "الصيانة" Then
       
       lr = Cells(Rows.Count, 7).End(xlUp).Row
 For r = 8 To lr
 y = Application.WorksheetFunction.IsNumber(Cells(7, 7))
 y1 = Application.WorksheetFunction.IsNumber(Cells(21, 7))
 If y And y1 And Cells(lr, 7) > 0 _
 And Cells(lr, 21) > 0 Then
 Cells(lr, 7) = Cells(lr, 7) + 1: Cells(lr, 21) = Cells(lr, 21) + 1
 End If
 Next
       End If

    Next

تم تعديل مايو 24, 2014 بواسطه شوقي ربيع

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

السلام عليكم

اخى الحبيب شوقى ربيع

اسال الله ان تكون بكل خير

اخى الحبيب

الكود الذى اريد التعديل عليه

يقوم باضافه عام للسن فى العمود g والخبرة التى فى العمود j

والكود يعمل بصوره منتظمة  ولا خلل به

المطلوب بدلا من كونى استخدم الكود عند دخول كل شيت على حدا

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

الادارية و الاتصالات و الغاز و المعمل و الطبية و الهندسية و الامن الصناعى والمهمات والانتاج والمعالجة والصيانة

ارجو تحميل الملف كى يتضح الامر

[شوقي ربيع]

لسلام عليكم

الكود السابق يعمل الذي تريده

كان به خطاء بسيط تم تعديله

جرب الكور واعلمني

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

السلام عليكم

عند تنفيز الكود يعطى لون اصفر على اسم الكود

Sub addition_1()

 

هل ممن الننكن تنفيزة على الملرفق

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

[شوقي ربيع]

هذا لأنك مكرر اسم الكود addition_1 اكثر من مرة غيره فقط

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

اخى الحبيب شوقى

اسم الكود غير مكرر

وضمان لذلك عيرت اسم الكود نهائى اكثر من مره 

والنتيجة اللون الاصفر Sub add()

اخى الحبيب

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

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

ترقية المستخدم.rar

[شوقي ربيع]

السلام عليكم

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

وفي حالتك هته مثلا لو ركزة قليل فقط  كنت ستكتشف بان عبارة  end sub ناقصة وهي العبارة التي ينتهي او يقفل بيها أي كود

على العموم اليك الملف مطبق عليه الكود

 

 

ترقية المستخدم_4.rar

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

السلام عليكم

اخى الحبيب شوقى اعتزر لك على كثره طلبات

اخى الحبييب

الكود عن تشغيله لا يعمل ولا يؤثر على اى شئ

وتم اضافىة Option Explicit

الا الكود لا يضيف اى شئ

فما الخطاء
 

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

للرفع