الـعيدروس

السلام عليكم هذا تعديل ربما يفي بالغرض 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 Cancel = True If MsgBox("هل تريد الغاء الكتاب" & vbCr & Target.Value, vbYesNo + vbMsgBoxRight) = vbYes Then With Application .ScreenUpdating = False .EnableEvents = False Target.Resize(1, 4).EntireRow.delete I = 1 R = 6 Do While I < Range("B1500").End(xlUp).Row - 6 Cells(R, 1).Value = I I = I + 1 R = R + 1 Loop .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم الالغاء " End If End If End If 1: 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 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 Range(Cells(Target.Offset(1, 0).Row, 2), Cells(B, 5)).Cut _ Destination:=Range(Cells(Target.Row, 2), Cells(B, 5)) .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم الالغاء " End If End If End If 1: 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.Cut R.Offset(-1, 0) Next .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم الالغاء " End If End If End If 1: End Sub

السلام عليكم الكود في حدث ThisWorkbook Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Cancel = True End Sub

بمناسبة عيد الأضحى المبارك اتقدم بأجمل التهاني والتبريكات بمناسبة حلول عيد الإضحى المبارك وكل عام وجميع أعضاء المنتدى من اداره و مشرفين واعضاء وزوار بخير وادعو الله العلي القدير ان يرجع حجاج بيته العظيم وهم بأتم صحه وعافيه ويحفظهم من كل مكروه ويرزقهم حج مبرور ونقول لكل الحجيج حج مبرور وسعي مشكور وذنب مغفور وكل عام والأمه الأسلاميه بأتم صحه وعافية

السلام عليكم تعديل بسيط على كود الاستاذ الحبيب الخالدي بعد اذنه Sub MENU_SheetLists() Dim CB_L As Object Dim CB_C As CommandBarControl On Error GoTo Error1: Application.CommandBars("MySheetList").Delete Error1: Set CB_L = CommandBars.Add(Name:="MySheetList", Position:=msoBarPopup) For Each Sh In ThisWorkbook.Worksheets Set CB_C = Application.CommandBars("MySheetList").Controls.Add(Type:=msoControlButton) With CB_C .Caption = Sh.CodeName: .OnAction = "GO_MySheet" End With Next Set CB_L = Nothing: Set CB_C = Nothing Application.CommandBars("MySheetList").ShowPopup End Sub Sub GO_MySheet() Sheets(Application.CommandBars.ActionControl.Index).Activate End Sub

السلام عليكم Private Sub ComboBox1_Change() LastRow = Cells(Rows.Count, "c").End(xlUp).Row + 1 If ComboBox1 <> "" Then Cells(LastRow, 3).Value = ComboBox1 End If ComboBox1 = "" End Sub

لا عليك احذف المعادلة

السلام عليكم جرب المرفق Shipment Tracking New Version15.xls_Ali_M_3.rar

السلام عليكم جرب هذا التعديل ان شاء الله يفي بالغرض والسموحه على التأخير تغيبنا عن النت لانشغالي Shipment Tracking New Version15.xls_Ali_M_2.rar

السلام عليكم Sub A_rc() Dim Cl As Range X = MsgBox(" هل ترغب بحذف الشيكات التى تم استلامها ", vbYesNo + vbMsgBoxRtlReading, " حذف سطر ") If X = vbYes Then Application.ScreenUpdating = False E = Cells(Rows.Count, 5).End(xlUp).Row For R = 2 To E If Cells(R, 5) = "لا" Then A = A & Cells(R, 5).Row B = B & "," & Cells(R, 5).Address End If Next EE = Right(B, Len(B) - 1) Range(EE).EntireRow.Delete MsgBox "عدد اسطر الشرط هيا" & ": " & Len(A), vbInformation, "تم" Else Range("A5").Select End If End Sub

السلام عليكم اضفت Combbox للبحث عن ورقة معينه مجرد ماتكتب اسم الورقة هيا التي تظهر في الفورمه فقط جرب وبلغنى بالنتائج تفضل المرفق Shipment Tracking New Version15.xls_Ali_M.rar

السلام عليكم تفضل جرب المرفق ملاحظه : اخفاء الاعمدة تنفذ للأوراق المحفزة في فورمة العملاء Shipment Tracking New Version12_Ali_3.rar

نتائج الكود تطابق نتائج المعادلة التي في العامود P شاهد المرفقات معادله الى كود.xlsx_A_1.rar

السلام عليكم Sub Al_S() Dim Rn As Range For Each Rn In Range("M5:O" & Cells(Rows.Count, 2).End(xlUp).Row).Rows If Application.Sum(Rn.Value) > 1 Then Cells(Rn.Row, "P") = 1 ElseIf Application.Sum(Rn.Offset(0, -9).Value) <> "" Then Cells(Rn.Row, "P") = 2 ElseIf Application.Sum(Rn.Value) > 0 Then Cells(Rn.Row, "P") = "" End If Next End Sub

السلام عليكم جرب المرفق Shipment Tracking New Version12_Ali_1.rar

السلام عليكم تفضل 1_A_ترحيل.rar

السلام عليكم Shipment Tracking New Version12_Ali.rar

الزر في ملف Sheet1 A_ترحيل.rar

السلام عليكم Sub T_Ali() On Error Resume Next With Application .ScreenUpdating = False .EnableEvents = False M_p = ActiveWorkbook.Path & "\" & "math" & ".xls" Workbooks.Open M_p For She = 1 To Workbooks("math").Sheets.Count Set c = Workbooks("math").Sheets(She) Set d = Workbooks("sheet1.xls").Sheets("fasl") Dim L_r Dim N_r L_r = c.Range("A65536").End(xlUp).Row N_r = d.Range("A65536").End(xlUp).Row + 1 c.Range(c.Cells(2, 1), c.Cells(L_r, 18)).Copy d.Range("A" & N_r).PasteSpecial xlPasteValues Next Application.CutCopyMode = False Workbooks("math").Close Workbooks("sheet1.xls").Sheets("fasl").Activate .ScreenUpdating = False .EnableEvents = False End With End Sub

استبدل السطر الثاني بهذا هذا المدى حسب طلبك Private Const A_1 As String = "D39:D45"

السلام عليكم بعد اذن استاذنا الحبيب عبدالله باقشير جرب هذا التعديل على الكود Sub kh_CopySheet() On Error GoTo ErrorHandler '''''''''''''''''''''''' Dim NewSheet As Worksheet Dim SheetName Dim Sh As Worksheet Dim C, C_1 Set Sh = Sheets("الرئيسية") ''''''''''''''''''''''''''''''' SheetName = InputBox("Please Insert sheet name.") If SheetName = Cancel Then Exit Sub If kh_Test_MyChr(CStr(SheetName)) = True Then Exit Sub '''''''''''''''''''''''''''''''' Set NewSheet = Sheets("CopySheet") NewSheet.Copy After:=Sheets(ThisWorkbook.Worksheets.Count) Set NewSheet = ActiveSheet '''''''''''''''''''''''' With NewSheet .Visible = xlSheetVisible .Name = CStr(SheetName) End With With Sh C = .Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row C_1 = NewSheet.Cells(Rows.Count, 3).End(xlUp).Row For Rr = 5 To 106 For Cc = 3 To 7 .Cells(Rr, Cc) = "=" & "'" & NewSheet.Name & "'" & "!" & .Cells(Rr, Cc).Address(False, False) Next Next End With '''''''''''''''''''''''''' ErrorHandler: If Err Then MsgBox "Err.Number : " & vbCr & Err.Number Set NewSheet = Nothing End Sub Function kh_Test_MyChr(khString As Variant) As Boolean Dim MySh As Worksheet Dim MyChArray, MyChr Dim S As Integer, R As Integer S = Len(Trim(khString)) If S > 31 Or S = 0 Then MsgBox "حروف الاسم قد تكون اصغر من 1 او اكبر من 31", 524288 + 1048576 + 16, "اسم مرفوض" kh_Test_MyChr = True Exit Function End If '------------------------------------ MyChArray = Array("/", "*", ":", "؟", "?", "[", "]") For Each MyChr In MyChArray If InStr(1, khString, MyChr, 1) <> 0 Then MsgBox "حروف الاسم تحتوي على الحرف " & Chr(10) & Chr(10) & Chr(9) & MyChr & Chr(10) & Chr(10) & "وهو من الاحرف الممنوعة " & "/ * : ؟ [ ]", 524288 + 1048576 + 16, "حرف ممنوع" kh_Test_MyChr = True Exit Function End If Next '------------------------------------ For Each MySh In ActiveWorkbook.Sheets If UCase(Trim(MySh.Name)) = UCase(Trim(khString)) Then MsgBox "الاسم مكرر ", 524288 + 1048576 + 16, "اسم مكرر" kh_Test_MyChr = True Exit Function End If Next End Function

السلام عليكم شرح الملف عكس طرحك جرب هذا الكود Option Explicit Option Base 1 Private Const Ali As String = "D24:D25" Private Const A_1 As String = "D31:D37" Sub test() On Error Resume Next Dim M As Range, M_1 As Range Set M = Range(Ali): Set M_1 = Range(A_1) If [D25] = "" Or [D39] = "" And [D41] = "" And [D43] = "" And [D45] = "" Then ALI_HID_C ورقة10, Union(M, M_1) End If End Sub Sub ALI_HID_C(ALI_SH As Worksheet, SH_A As Range) Dim F_ALI() As Variant Dim Cell As Range Dim I As Integer With Application .ScreenUpdating = False .EnableEvents = False ReDim Preserve F_ALI(SH_A.Cells.Count) For Each Cell In SH_A I = I + 1 F_ALI(I) = Cell.Rows Next Cell SH_A.Rows.Hidden = True .ScreenUpdating = True ورقة10.PrintPreview .ScreenUpdating = False I = 0 For Each Cell In SH_A I = I + 1 Cell.Rows.Hidden = False Next Cell .ScreenUpdating = True .EnableEvents = True End With End Sub

السلام عليكم بعد تعديل المسار ونوع الملف إنسخ الكود إلى حدث المصنف ThisWorkbook Private Sub Workbook_Open() Dim MyPath As String '***************************** ' مسار الملف MyPath = "D:\SHARED GENERAL" ' هنا '***************************** If ThisWorkbook.Path <> MyPath Then Application.DisplayAlerts = False ThisWorkbook.Close End If Dim MyFlName As String '******************* ' نوع الملف 2003 او 2007 MyFlName = "TEST-1.xls" ' 2003 = xls : 2007 = xlsm '******************* If ThisWorkbook.Name <> MyFlName Then Application.DisplayAlerts = False ThisWorkbook.Close End If End Sub Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim lReply As Long If SaveAsUI = True Then lReply = MsgBox("عفواً لايمكنك حفظ هذا الملف بإسم جديد .. هل تريد حفظ الملف بإسمه الحالي ؟", vbQuestion + vbOKCancel) Cancel = (lReply = vbCancel) If Cancel = False Then Me.Save Cancel = True End If End Sub

السلام عليكم جرب هذا الكود Sub ali_Sh() On Error Resume Next Dim Sh As Worksheet Dim Rn As Range With Application .ScreenUpdating = False .EnableEvents = False A = ActiveSheet.Name For Each Sh In ThisWorkbook.Worksheets With ActiveSheet For Each Rn In .Range("K3:K" & .Cells(Rows.Count, 11).End(xlUp).Row) If Rn = Sh.Name Then .Range("C" & Rn.Row).Copy Sh.Select Sh.Cells(Sh.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row, "C").PasteSpecial xlPasteValues Sheets(A).Select End If Application.CutCopyMode = False Next End With Next .ScreenUpdating = True .EnableEvents = True End With End Sub Book1_A.rar

السلام عليكم عندي تظهر خطأ الويندوز عندي Windows 7