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

السلام عليكم
الاخ الكريم ابو علي و سدرة
جزاك الله كل على وقتك ومجهودك 
اخى الحبيب استخدام كود وذلك لان القيم المتغيره  هى المراد ترحلها 
والمعادلات تجعل اى اسم غير موجد امامه قيمه صفر
وتم حبل الامر بكود من ابداع الاخ حسام ..جزاه الله كل الخير والتقدير
مرفق الكود لاستفاده لمن اراد
Sub alsqr() For i = 30 To 40 For r = 2 To 20 If Cells(i, 2) = Cells(r, 2) Then Cells(r, 6) = Cells(i, 4) End If Next Next End Sub  

الحمد لله
تم بحمد الله  عمل الكود وذلك بتتبع اعمال الاخ الكبير بن علية حاجى
والاخ الكريم ياسر ابو البراء
 
ولهم كل الشكر والتقدير فيما يفمو به من شرح وافى لما يقدمونه من اعمال
جزاكهم الله كل الخير
الكود لمن اراد الاستفاده
Sub printing() Application.ScreenUpdating = False On Error Resume Next sama = MsgBox("سيتم طباعة جميع الشيتات بالشرط... هل أنت متأكد من إجراء هذه العملية ؟", vbYesNo, "الشئون الادارية .. حقول طارق @ طباعة جميع الشيتات@") If sama = vbYes Then For Each Sh In Worksheets If Sh.[A1] = "print" Then Sh.PrintOut Copies:=1 Next Else MsgBox " !! لم تتم الطباعة " End If Application.ScreenUpdating = True Sheets("1").Select End Sub

السلام عليكم
تم اصلاح الكود بعد النظر فى ود قد قدمه الاخ احمد حمور فى الموضوع التالى 
http://www.officena.net/ib/index.php?showtopic=33810&hl=%2Bكود+%2Bلعمل+%2Bنسخه+%2Bاحتياطيه
 
فاصبح الكود 
وانت المشكله تكمن فى الجزء الملون باللون الاحمر
 
Private Sub Workbook_BeforeClose(Cancel As Boolean) ThisWorkbook.Save Application.DisplayAlerts = False If Date >= #1/26/2014# And Time >= #6:45:00 AM# Then If Application.UserName = "ahmed.moh" Or Application.UserName = "MOHAMED.AHMED" Then ActiveWorkbook.SaveAs "D:\" & ThisWorkbook.Name ActiveWorkbook.SaveAs "D:\today.xls", FileFormat:=xlExcel8 End If End If   End Sub

جزاكم الله خيرا تم البحث وايجاد الحل باللمنتدى
 
Public ss As Byte
Sub addition1()
On Error Resume Next
pass = "240"
sama = InputBox("برجاء ادخل كلمة المرور")
If sama <> pass Then
ss = ss + 1
MsgBox ("كلمةالمرور خطاء ...الادخال الخاطئ اكثر من 3 محاولات يغلق البرنامج" & Chr(10) & " " & "باقى لك عدد" & " " & 3 - ss & " " & "محاولة")
If ss >= 3 Then
Application.Quit
End If
Exit Sub
End If
Dim ER, R, SH
For SH = 2 To 2
 Application.ScreenUpdating = False
Sheets(SH).Select
Sheets(SH).Unprotect "5240"
ER = Sheets(SH).UsedRange.Rows.Count
For R = 8 To ER
If WorksheetFunction.IsNumber(Cells(R, 8)) = True And _
Cells(R, 8) <> 0 Then Cells(R, 8) = Cells(R, 8) + 1
If WorksheetFunction.IsNumber(Cells(R, 11)) = True And _
Cells(R, 11) <> 0 Then Cells(R, 11) = Cells(R, 11) + 1
Next R
On Error Resume Next
Application.ScreenUpdating = True
MsgBox "تم اضافة عام للخبرة والسن ... وشكرا.." & CHR10 & Sheets(SH).Name, vbMsgBoxRight, "الحمدلله"
Sheets(SH).Protect "5240"
Next SH
End Sub
Sub remove1()
On Error Resume Next
pass = "240"
sama = InputBox("برجاء ادخل كلمة المرور")
If sama <> pass Then
ss = ss + 1
MsgBox ("كلمةالمرور خطاء ...الادخال الخاطئ اكثر من 3 محاولات يغلق البرنامج" & Chr(10) & " " & "باقى لك عدد" & " " & 3 - ss & " " & "محاولة")
If ss >= 3 Then
Application.Quit
End If
Exit Sub
End If
Dim ER, R, SH
For SH = 2 To 2
 Application.ScreenUpdating = False
Sheets(SH).Select
Sheets(SH).Unprotect "5240"
ER = Sheets(SH).UsedRange.Rows.Count
For R = 8 To ER
If WorksheetFunction.IsNumber(Cells(R, 8)) = True And _
Cells(R, 8) <> 0 Then Cells(R, 8) = Cells(R, 8) - 1
If WorksheetFunction.IsNumber(Cells(R, 11)) = True And _
Cells(R, 11) <> 0 Then Cells(R, 11) = Cells(R, 11) - 1
Next R
On Error Resume Next
Application.ScreenUpdating = True
MsgBox "تم حذف من الخبرة والسن ... وشكرا.." & CHR10 & Sheets(SH).Name, vbMsgBoxRight, "الحمدلله"
Sheets(SH).Protect "5240"
Next SH
End Sub

الاخ الكريم ابراهيم ابو ليلة
وجت كود من عملك ايضا
وقام بالمهمة المرجوة
جزاك الله خيرا
 
()Private Sub Worksheet_Activate
Range("A4") = ActiveSheet.Name
End Sub

السلاكم عليكم
تم الحل بعد البحث فى المنتدى ووجدت حل مماثل للاخ الكبير بن علية حاجى
جزاة الله كل الخير وسلمت يداه
وذلك عن طرق المعادلة (INDIRECT("'"&A1&"'!A1=

من باب الافاده 
مرفق الفروق بين FileFormat وامتداد الملف  لاخ الكبير بن علية خاجى
 
تلاحظ أن في كل نسخة من أكسيل كل امتداد في "الحفظ باسم" له خصوصيته في خاصية FileFormat...
 
* في إكسيل 2003 : للحفظ باسم Ahmed.xls في المسار D:\
 
ActiveWorkbook.SaveAs Filename:="D:\Ahmed.xls", FileFormat:=xlNormal
* في إكسيل 2010 :
 
- للحفظ باسم Ahmed.xls في المسار D:\
ActiveWorkbook.SaveAs Filename:="D:\Ahmed.xls", FileFormat:=xlExcel8
- للحفظ باسم Ahmed.xlsx  في المسار D:\
ActiveWorkbook.SaveAs Filename:="D:\Ahmed.xlsx", FileFormat:=xlOpenXMLWorkbook
- للحفظ باسم Ahmed.xlsm  في المسار D:\
ActiveWorkbook.SaveAs Filename:="D:\Ahmed.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
- للحفظ باسم Ahmed.xlsb في المسار D:\
ActiveWorkbook.SaveAs Filename:="D:\Ahmed.xlsb", FileFormat:=xlExcel12
تلاحظ أن في كل نسخة من أكسيل كل امتداد في "الحفظ باسم" له خصوصيته في خاصية FileFormat...

الاخوة الافاضل
 
تم عمل المطلوب وذلك بعد الرجوع الى ما قدمه لى الاخ طارق محمود والاخ بن على حاجى فى موضوع استدعاء بيانات واستعلام برقم
http://www.officena.net/ib/index.php?showtopic=48593#entry294237
http://www.officena.net/ib/index.php?showtopic=48576&hl=
جزا الله الجميع كل الخير
مرفق الملف بعد التعديل
ارجو ان يكون صحيح ولا تبخلو عنى بالنصيحه
استعلام 1هام.rar

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