الـعيدروس

السلام عليكم استاذ عبدالله فعلا ناقص امر عندك يتعدل السطر تعريف المتغير كالتالي من Dim Voice As SpVoice الى Dim Voice As SpeechLib.SpVoice وبرضه في وسط الكود من Set Voice = New SpVoice الى Set Voice = New SpeechLib.SpVoice وفي Reference ثم Browser وتضيف هذا المرجع C:\Windows\System32\Speech\Common\sapi.dll

السلام عليكم بعد تنفيذ الكود خلية " G2 " في ورقة الرئيسية في قائمة التحقق من الصحة حط هذه المرجع =Data وهذا الكود وبه تعديل لحذف الاسم من ورقة البيانات بعد نقله Private Sub الريئسية_Click() Dim Sh As Worksheet, S As Worksheet Dim r As Range, Rn As Range, Rr%, A%, B% Set r = Range("G2") Set S = ورقة3 Set Sh = ورقة2 Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row) On Error Resume Next With Rn For Rr = 1 To .Rows.Count If .Cells(Rr, 1).Value = r.Value Then .Rows(Rr).Copy S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues B = .Range(.Cells(Rr, 17), .Cells(Rr, 23)).Copy A = .Cells(Rr, 1).Row Exit For End If Next With Sh .Cells(A, 1).EntireRow.Delete Shift:=xlUp .Application.ScreenUpdating = False .Application.EnableEvents = False .Range(.Cells(6, 18), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 24)).PasteSpecial xlPasteFormulas .Range(.Cells(6, 18), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 18)).FormulaR1C1 = "=FLOOR((RC[-7]+RC[-5])*R1C16,0.01)" .Range(.Cells(6, 19), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 19)).FormulaR1C1 = "=FLOOR((RC[-7]+RC[-6])*R1C18,0.01)" .Range(.Cells(6, 20), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 20)).FormulaR1C1 = "=SUM(RC[-6]:RC[-2])" .Range(.Cells(6, 21), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 21)).FormulaR1C1 = _ "=IF(R[1]C[113]=""احتساب"",SUM(RC[-7]:RC[-2])*(R[1]C[111]-R[1]C[110])/R[1]C[111],SUM(RC[-7]:RC[-2]))" .Range(.Cells(6, 22), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 22)).FormulaR1C1 = _ "=IF(RC[-19]=""مدير عام أ"",10,IF(RC[-19]=""مدير عام"",6,IF(RC[-19]=""الأولى"",5,IF(RC[-19]=""الثانية"",5,IF(RC[-19]=""الثالثة"",4,IF(RC[-19]=""الرابعة"",2,IF(RC[-19]=""الخامسة"",1.5,IF(RC[-19]=""السادسة"",1.5,0))))))))" .Range(.Cells(6, 23), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 23)).FormulaR1C1 = _ "=IF(R[1]C[111]=""احتساب"",SUM(RC[-12],RC[-10])*(R[1]C[109]-R[1]C[108])/R[1]C[109],SUM(RC[-12],RC[-10]))" .Range(.Cells(6, 24), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 24)).FormulaR1C1 = _ "=IF(R[1]C[110]=""احتساب"",SUM(RC[-12],RC[-11])*(R[1]C[108]-R[1]C[107])/R[1]C[108],SUM(RC[-12],RC[-11]))" .Range(.Cells(6, 2), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data" .Application.EnableEvents = True .Application.ScreenUpdating = True End With Application.CutCopyMode = False sss.Select End With End Sub

السلام عليكم ******************* ملف به تحكم بإعدادات الفورم ******************* أحببت أن أهديه للجميع Form_All_Controls_2003.rar Form_All_Controls_2007.rar

السلام عليكم ******************* ملف به تحكم بإعدادات الفورم ******************* أحببت أن أهديه للجميع

الكود يلغي النقل او النسخ ولاكن ملاحظة استاذي عبدالله باقشير بمحلها عند تحديد اكثر من ورقة انا بحاول اتوصل الى حل ان شاء الله

السلام عليكم الله يبارك فيك اخي يوسف اعاده الله علينا وعليكم وعلى الامه الاسلاميه باليمن والبركه استبدل السطر بهذا N = Application.CommandBars.ActionControl.Index

السلام عليكم بعد اذن استاذنا القدير خبور خير بيكون الكود بعد التعديل هكذا Option Explicit Const mBr As String = "MySheetList" Sub kh_AddName() Dim Nam As Range Dim i As Integer Dim NamSheet As String ''''''''''''''''''''''''''''''' On Error GoTo kh_Err ''''''''''''''''''''''''''''''' kh_BarDelete ''''''''''''''''''''''''''''''' Set Nam = ورقة1.Range("E2:AH3") ''''''''''''''''''''''''''''''' With Application.CommandBars.Add(Name:=mBr, Position:=msoBarPopup) For i = 1 To Nam.Columns.Count NamSheet = Nam.Cells(2, i) With .Controls.Add(Type:=msoControlButton) .Caption = Nam.Cells(1, i) .OnAction = "GO_MySheet" .Tag = NamSheet If NamSheet = ActiveSheet.Name Then .State = -1 If IsError(Evaluate("'" & NamSheet & "'!A1")) Then .Enabled = False End If End With Next End With ''''''''''''''''''''''''''''''' Application.CommandBars(mBr).ShowPopup ''''''''''''''''''''''''''''''' kh_Err: Set Nam = Nothing If Err Then MsgBox "Err.Number : " & Err.Number kh_BarDelete End Sub Sub kh_BarDelete() On Error Resume Next Application.CommandBars(mBr).Delete On Error GoTo 0 End Sub Sub GO_MySheet() Dim N As String N = Application.CommandBars.ActionControl.Tag Sheets(N).Activate End Sub

السلام عليكم جزاك الله خير استاذ عبدالله

السلام عليكم الاخ الفاضل الجزيره هذا الكود في حدث Thisworkbook يمنع ادراج ورقة جديدة بالامكان استخدامه Private Sub Workbook_NewSheet(ByVal SH As Object) MsgBox "لقد تمت عملية إدراج الورقة بنجاح. ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading Application.DisplayAlerts = False MsgBox "ولكن، لا يمكنك إدراج أي ورقة جديدة بهذا البرنامج. ", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading ActiveSheet.Delete MsgBox "وقد تمت عملية حذف الورقة بنجاح أيضاً. ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading Application.DisplayAlerts = True End Sub

السلام عليكم Public Sub Ali_T() Dim Sh As Worksheet Dim r As Range, Rn As Range Set r = Range("G2") Set Sh = ورقة2 With Sh For Each Rn In .Range("B6:B" & .Cells(Rows.Count, 1).End(xlUp).Row) If Rn = r.Value Then .Range(Cells(Rn.Row, 2).Address, Cells(Rn.Row, 24).Address).Copy With Sheets("المفقولون") .Select .Range("B" & .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues End With sss.Select End If Next حل بطريقة اخرى انسخ الكود في حدث الزر في ورقة الرئيسية Dim Sh As Worksheet, S As Worksheet Dim r As Range, Rn As Range, Rr% Set r = Range("G2") Set S = ورقة3 Set Sh = ورقة2 Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row) With Rn For Rr = 1 To .Rows.Count If .Cells(Rr, 1).Value = r.Value Then Rn.Rows(Rr).Copy S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues Exit For End If Next Application.CutCopyMode = False End With fz55_Ali.rar

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

السلام عليكم ظهور كلمة الأجمالي بعد اخر صف به بيانات_1.rar

الحمد لله

السلام عليكم تفضل هذا التعديل Sub jana() Dim R As Range Dim A% Dim Calcu As XlCalculation Calcu = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '======================== On Error Resume Next Set R = Range("data") Addliste R.Columns(3), "marey" If Val(Application.WorksheetFunction.CountA(R.Value)) > 2 Then With Sheets("marey") .Range("G" & .Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).Row) = " الإجمـــالي" End With Else End If '======================== Application.ScreenUpdating = True Application.Calculation = Calcu End Sub

السلام عليكم تفضل المرفق Serch_Column_2010_1.rar

السلام عليكم بيكون الكود بهذا الشكل Sub jana() Dim Calcu As XlCalculation Calcu = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '======================== Addliste Range("data").Columns(3), "marey" With Sheets("marey") .Range("G" & .Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).Row) = " الإجمـــالي" End With '======================== Application.ScreenUpdating = True Application.Calculation = Calcu End Sub

ولمعرفة الكثير حول أرقام ID لدالة FindControl Public Sub Com_All() Dim R&, Ro%, E% On Error Resume Next With Application .ScreenUpdating = False .EnableEvents = False Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).ClearContents Range("A1:C1") = Array("تسلسل الرقم", "ايدي الامر", "نوعه المسمى") R = 2 For Ro = 1 To 12500 Cells(R, 1) = Application.CommandBars.FindControl(ID:=Ro).Type Cells(R, 2) = Application.CommandBars.FindControl(ID:=Ro).ID '*** Cells(R, 3) = Application.CommandBars.FindControl(ID:=Ro).Caption R = R + 1 Next E = Range("A20000").End(xlUp).Row With Range("C2:C" & E) .VerticalAlignment = xlRight .HorizontalAlignment = xlRight End With For I = E To 2 Step -1 If Range("A" & I).Value = "" Then Range("A" & I).EntireRow.Delete Next .EnableEvents = True .ScreenUpdating = True End With End Sub

عندي اوفيس 2007 تأكد من إعدادات الماكرو و تفعيل الثقة في الوصول إلى كائن مشروع VBA شاهد الصور في المرفقات توضيح.rar

الاخ الفاضل يوسف عطا مسمى الورقة ( Name و CodeName ) شاهد المرفق Sh_Ca.rar

السلام عليكم تفضل المرفق به ماتريد إن شاء الله Serch_Column.rar Serch_Column_2010.rar

السلام عليكم الاخ الحبيب الدهشوري عظم الله اجرك واحسن عزاك واسكن فقيدكم الفردوس الاعلى البقاء لله أسأل الله ان يحسن مثواه ويكرم نزله ويدخله فسيح جناته

السلام عليكم تفضل المرفق وبه ملاحظة اخونا الفاضل أبو انس Canel_Delete_Sheet.rar

السلام عليكم هذه الأكواد انسخها الى حدث ThisWorkbook لنفترض أنا الورقتين المراد عدم حذفها اساميهم "ورقة1" , "ورقة2" Private Sub Workbook_Open() Dim S$ With ActiveSheet S = .Name If S = "ورقة1" Or S = "ورقة2" Then Alidroos_Control_F Else Alidroos_Control_T End If End With End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) If Sh.Name = "ورقة1" Or Sh.Name = "ورقة2" Then Alidroos_Control_F Else Alidroos_Control_T End If End Sub Private Sub Alidroos_Control_F() If Not Application.CommandBars Is Nothing Then With Application.CommandBars .FindControl(ID:=847).Enabled = False .FindControl(ID:=848).Enabled = False End With End If End Sub Private Sub Alidroos_Control_T() If Not Application.CommandBars Is Nothing Then With Application.CommandBars .FindControl(ID:=847).Enabled = True .FindControl(ID:=848).Enabled = True End With End If End Sub

السلام عليكم تعديل للكود الاخير لطلبك الاخير Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column = 2 Then If Me.FilterMode Then GoTo 1 If Not Application.Intersect(Target, Range("b6:b24")) Is Nothing Then On Error Resume Next Dim R As Range Dim B& Cancel = True If MsgBox("هل تريد الغاء الكتاب" & vbCr & Target.Value, vbYesNo + vbMsgBoxRight) = vbYes Then With Application .ScreenUpdating = False .EnableEvents = False B = Cells(Rows.Count, 2).End(xlUp).Row Target.Resize(1, 4).ClearContents For Each R In Range(Cells(Target.Offset(1, 0).Row, Target.Column), Cells(B, 5)).Areas R.Offset(-1, 0).Value = R.Value Next Range("B" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 4).ClearContents .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم الالغاء " End If End If End If 1: End Sub

استاذنا العبقري خبور خير كلماتك وسام من ذهب واعتز بها وفقك الله وسدد خطاك كود جميل من الاستاذ الخالدي وتعديل بسيط لايذكر