الـعيدروس

السلام عليكم تفضل Private Const Ali_Sta As String = "-" Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect([D4:D10,F4:F10], Target) Is Nothing Then If Target.Value > 0 Then Target.Font.Color = RGB(255, 0, 0) Target.Value = Ali_Sta & Target.Value Exit Sub End If End If End Sub

السلام عليكم تفضل جرب هذا التعديل Private Const S_Ali As String = "$G$2" Sub Sum_A() Dim Sh As Worksheet Dim A As Double For Each Sh In ActiveWorkbook.Worksheets Select Case Sh.Name '''''''''''''''''''''''''''' Case "Main", "Totals" ''''''''''''''''''''''' Case Else A = A + Sh.Range(S_Ali).Value End Select Next Sheets("Main").[I1] = A End Sub

شركة تصميم ازياء ام ماذا ؟؟؟

السلام عليكم جزاك الله خير اخي الحبيب رجب جاويش الاخ الفاضل RinaUnallyCar ردودك تظهرعلى شكل روابط ارجو توضيح ماتريد

السلام عليكم جرب هذا الكود Public Sub Ali_F() Dim Rt As Range Set Rt = [A1] With [A2] Select Case S_F(Rt) Case Is = 255 .Value = "تم" Case Is = 0 .Value = "غير تام" End Select End With End Sub Public Function S_F(ByVal C_R As Range) As Integer Dim Colr As String Colr = C_R.FormatConditions(1).Interior.Color S_F = Colr End Function Tamer_A.rar

السلام عليكم او هكذا في حدث الورقة Private Const A_1 As String = "$H$1" Private Const A_2 As String = "$j$1" Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error Resume Next Dim R1 As Range Set R1 = Range("E4:E4500,F4:F4500,G4:G4500") '****************************************** If Not Intersect(Target, R1) Is Nothing Then R = Target.Row If Val(Range(A_1)) = Val(Cells(R, 5)) Then Cells(R, 8) = Cells(R, 7) Else Cells(R, "H") = "" End If If Val(Range(A_1)) = Val(Cells(R, 6)) Then Cells(R, 9) = Cells(R, 7) Else Cells(R, "I") = "" End If If Val(Range(A_2)) = Val(Cells(R, 5)) Then Cells(R, 10) = Cells(R, 7) Else Cells(R, "J") = "" End If If Val(Range(A_2)) = Val(Cells(R, 6)) Then Cells(R, 11) = Cells(R, 7) Else Cells(R, "K") = "" End If End If End Sub

السلام عليكم الاخ الحبيب أبو تميم اشكرك على هذا المرور العطر والكلمات الطيبه تقبل تحياتي وشكري

السلام عليكم جرب هذه الاكواد مجرد النقر مرتين في العمود الملون بالاصفر تظهر قائمة وبها تكتب الاسم المراد يتحفز مجرد البحث هذا الكود في حدث الورقة Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, [C5:C101]) Is Nothing Then Call AD_Ali(ActiveSheet, Target) Cancel = True End If End Sub Private Sub E_Ali() On Error Resume Next Dim obj_A As OLEObject For Each obj_A In ActiveSheet.OLEObjects If obj_A.progID = "Forms.ComboBox.1" Then obj_A.Delete Next obj_A End Sub Private Sub M_Comb_Click() With M_Comb ActiveCell.Value = .Value End With E_Ali End Sub وهذا الكود في مودويل Option Explicit Option Base 1 Sub AD_Ali(Sh As Object, Target As Range) On Error Resume Next With Sh .Range(.Cells(5, 13).Address, .Cells(.Cells(Rows.Count, 13).End(xlUp).Row, 13).Address).Name = "M_D" End With With Target With ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _ Link:=False, DisplayAsIcon:=False, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) .Name = "M_Comb" .ListFillRange = "M_D" End With End With End Sub جرب وبلغنى بالنتائج Ali_Combo.rar

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

السلام عليكم جرب هذا الكود سجلت ملف صوتي وتم إستخدامه في الملف هذا الكود في مودويل Public Declare Function Aud_Ali Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long وهذا الكود في حدث "Thisworkbook" Private Const Sr_Ali As String = "as.wav" Private Sub Workbook_Open() Dim S As Worksheet Dim R As Range Set S = Sheets("Sheet1") Path_A = ThisWorkbook.Path & ThisWorkbook.Application.PathSeparator & Sr_Ali For Each R In S.Range("D5:D20") If R <= [B1] And Not IsEmpty(R) Then Aud_Ali Path_A, 0& MsgBox "العقد التالي إنتهى " & ": " & "[" & R.Offset(0, -2).Text & "]" & " بتاريخ :" & R.Text & " تاريخ اليوم :" & WorksheetFunction.Text([B1], "YYYY,MM,DD"), vbExclamation, "تنبية !!!" End If Next End Sub على أن يكون الملف الصوتي مرفق في نفس فولدر ملف الاكسل أتمنى أن أكون افدتك وأي تعديلات او اضافات انا موجود D_Ali.rar

السلام عليكم اعتقد في البحث مباشرة الاسطر التاليه ليس لها داعي لانها تحدد المدى عند البحث بمعنى تعيق عملية البحث Range("a4:o4").Select Selection.AutoFilter

السلام عليكم الاستاذ الحبيب محمود علي بالامكان الكود يكون في حدث الورقة في حدث "TextBox1_Change" للبحث مباشره كالتالي Private Sub TextBox1_Change() Dim LastRow As Long LastRow = Range("c65535").End(xlUp).Row If TextBox1.Text <> "" Then Range("$a$4:$o$" & LastRow).AutoFilter Field:=3, Criteria1:="=" & TextBox1.Text & "*", Operator:=xlOr Else Range("$a$4:$o$" & LastRow).AutoFilter Field:=3 End If End Sub

السلام عليكم اضغط الملف عن طريق برامج الضغط " Winrara" أو "WinZib" ثم أرفقه

السلام عليكم الاخ الحبيب أبو أنس حاجب جزاك الله كل خير على دعائك وكلماتك الطيبه ولك مثل دعائك اضعاف مضاعفه ان شاء الله تفضل هذا الكود بعد التعديل لطلبك الاخير Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Ali_Val End Sub Private Sub Ali_Val() X = Range("A65536").End(xlUp).Offset(1, 0).Row With Cells(X, 1) .Value = ActiveSheet.ComboBox2.Value .Select End With End Sub

السلام عليكم هذه طريقة تنفذ الطريقتين بإختصار زر معين هذا الكود في حدث Thisworkbook Private Sub Workbook_Open() Application.OnKey "{F3}", "Ali" End Sub وهذا الكود في مودويل Dim R As Boolean Public Sub Ali() A = ActiveCell.Formula B = "'": C = "" R = Not R If Not B = C Then E = IIf(R, B, C) ActiveCell.Value = E & A End Sub تفعل الماكرو بزر "F3" الجمع بالالوان_Ali.rar

السلام عليكم لإظهار الصيغة تضيف قبل علامة " = " علامة " ' " التي هيا زر حرف ط بالحروف الانكليزيه هكذا '=SUM(G19:G25)

السلام عليكم لاثراء الموضوع تفضل جرب هذا الكود Sub M_ALI() Application.ScreenUpdating = False Q = [C15000].End(xlUp).Row Cm = Chr(10) & "غير موجود في عمود D" For R = 4 To Q If Application.WorksheetFunction.CountIf([D2:D500], Cells(R, 3)) = 0 Then With Cells(R, 3) .Interior.Color = RGB(255, 0, 0) .AddComment Text:=Cm .Comment.Visible = True .Comment.Shape.TextFrame.AutoSize = True End With End If Next RO = [D15000].End(xlUp).Row Cm1 = Chr(10) & "غير موجود في عمود C" For R = 4 To RO If Application.WorksheetFunction.CountIf([C4:C500], Cells(R, 4)) = 0 Then With Cells(R, 4) .Interior.Color = RGB(255, 0, 0) .AddComment Text:=Cm1 .Comment.Visible = True .Comment.Shape.TextFrame.AutoSize = True End With End If Next Application.ScreenUpdating = True End Sub

السلام عليكم تفضل Private Sub ComboBox2_Change() With ComboBox2 Range("A65536").End(xlUp).Offset(1, 0).Select ActiveCell.Value = .Value End With End Sub

السلام عليكم استخدمت القائمة العامودي تفضل جرب على هذا الرابط http://www.4shared.com/rar/uwYlbgR3/___1.html حجم الملف كبير لم يقبل الرفع في المنتدى

السلام عليكم جرب التعديل التالي مع اضافة سطر تجاهل رسائل الخطاء Sub GO_MySheet() Dim N On Error Resume Next N = Application.CommandBars.ActionControl.Index Sheets(N).Activate End Sub

السلام عليكم تفضل Public Sub ali_T() Dim r As Range, A, Ali_Path$ Str_A = "[Serv_" [B1].ColumnWidth = 64.15 Rt = 1 Ali_Path = "C:\Ali\gg.txt" '*************************************** ' C:\Ali\gg.txt المسار ' غيره حسب مسار ملف التكست والمسمى Open Ali_Path For Output As #1 '*************************************** With Application .ScreenUpdating = False .EnableEvents = False For Each r In Range("A1:A256") At = Replace(r.Text, "C:", "server=") If Not IsEmpty(r) Then A = Str_A & Rt & "]" & Chr(10) & At & Chr(10) Cells(Rt, 2) = A Print #1, Str_A & Rt & "]" & vbCrLf & At & vbCrLf Rt = Rt + 1 End If Next .ScreenUpdating = True .EnableEvents = True End With Close #1 End Sub

السلام عليكم جرب هذا الكود هذا في حدث Thisworkbook Option Explicit Dim vidwidth As Integer Dim vidheight As Integer Dim Msg Dim ans Dim msg1 Private Sub Workbook_Open() If Left(Application.Version, 1) = 5 Then ' 16-bit Excel vidwidth = GetSystemMetrics16(SM_CXSCREEN) vidheight = GetSystemMetrics16(SM_CYSCREEN) Else ' 32-bit Excel vidwidth = GetSystemMetrics(SM_CXSCREEN) vidheight = GetSystemMetrics(SM_CYSCREEN) If vidwidth = 1024 And vidheight = 960 Then Exit Sub Else Msg = "دقة الشاشة الحالية: " msg1 = Msg & vidwidth & "x" & vidheight Msg = msg1 & vbCr & vbLf & "هذا التطبيق يحتاج إلى دقة أعلى ليعمل بشكل صحيح." _ & vbLf & "هل ترغب في تغيير الوضع إلى 1024x768 الآن؟" ans = MsgBox(Msg, vbYesNo, "تغيير دقة الشاشة؟") If ans = vbYes Then ' وضع الشاشة الذي تريده العرض والطول واللون ChangeScreenSettings 1024, 960, 32, 75 Else End If End If End If End Sub وهذا الكود في مودويل Public Const CCDEVICENAME = 32 Public Const CCFORMNAME = 32 Public Const DISP_CHANGE_SUCCESSFUL = 0 Public Const DISP_CHANGE_RESTART = 1 Public Const DISP_CHANGE_FAILED = -1 Public Const DISP_CHANGE_BADMODE = -2 Public Const DISP_CHANGE_NOTUPDATED = -3 Public Const DISP_CHANGE_BADFLAGS = -4 Public Const DISP_CHANGE_BADPARAM = -5 Public Const CDS_UPDATEREGISTRY = &H1 Public Const CDS_TEST = &H2 Public Const DM_BITSPERPEL = &H40000 Public Const DM_PELSWIDTH = &H80000 Public Const DM_PELSHEIGHT = &H100000 Public Type DEVMODE dmDeviceName As String * CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Declare Function GetSystemMetrics16 Lib "user" Alias "GetSystemMetrics" (ByVal nIndex As Integer) As Integer Public Const SM_CXSCREEN = 0 Public Const SM_CYSCREEN = 1 Public Sub ChangeScreenSettings(lWidth As Integer, lHeight As Integer, lColors As Integer, lfrequency As Integer) Dim tDevMode As DEVMODE, lTemp As Long, lIndex As Long lIndex = 0 Do lTemp = EnumDisplaySettings(0&, lIndex, tDevMode) If lTemp = 0 Then Exit Do lIndex = lIndex + 1 With tDevMode If .dmPelsWidth = lWidth And .dmPelsHeight = lHeight _ And .dmBitsPerPel = lColors And .dmDisplayFrequency = lfrequency Then lTemp = ChangeDisplaySettings(tDevMode, CDS_UPDATEREGISTRY) Exit Do End If End With Loop Select Case lTemp Case DISP_CHANGE_SUCCESSFUL Case DISP_CHANGE_RESTART MsgBox "يجب إعادة تشغيل الكمبيوتر من أجل تعديل دقة الشاشة", vbQuestion Case DISP_CHANGE_FAILED MsgBox "فشل برنامج تشغيل العرض لوضع الرسومات المحدد", vbCritical Case DISP_CHANGE_BADMODE MsgBox "غير معتمد وضع الرسومات", vbCritical Case DISP_CHANGE_NOTUPDATED MsgBox "غير قادر على الكتابة في إعدادات التسجيل", vbCritical Case DISP_CHANGE_BADFLAGS MsgBox "تجاوزت بيانات غير صالحة", vbCritical End Select End Sub

السلام عليكم جرب هكذا Type S_Ali V_A As Variant D_A As String End Type Public Sub Ali_T() Dim Ali_Rn() As S_Ali Dim Sh As Worksheet, S As Worksheet, Sn As Worksheet Dim R As Range, Rn As Range, Rr%, E, EE Dim CE As Range Dim Rtt As Range Set R = Range("G2") Set S = ورقة3 Set Sh = ورقة2 Set Sn = ورقة1 Set Rn = Sh.Range("B6:IP" & 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 xlPasteFormulasAndNumberFormats .Rows(Rr).ClearContents a = .Cells(Rr, 1).Row Exit For End If Next With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual b = Sh.Cells(Rows.Count, 2).End(xlUp).Row With Sh Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 250).Address) If TypeName(Rtt) <> "Range" Then Exit Sub ReDim Ali_Rn(Rtt.Count) I = 0 For Each CE In Rtt I = I + 1 Ali_Rn(I).D_A = CE.Address Ali_Rn(I).V_A = CE.FormulaR1C1 Next CE .Range(.Cells(a, 2).Address, .Cells(b, 250).Address).ClearContents End With For I = 1 To UBound(Ali_Rn) Sh.Range(Ali_Rn(I).D_A).Offset(-1, 0).FormulaR1C1 = Ali_Rn(I).V_A Next I Sh.Range(Cells(6, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data" Sn.Activate .Calculation = xlCalculationAutomatic .EnableEvents = True .ScreenUpdating = True End With Application.CutCopyMode = False Erase Ali_Rn Set CE = Nothing: Set Rn = Nothing Set R = Nothing: Set Rtt = Nothing End With End Sub

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

وعليكم السلام ورحمة الله وبركاته اخي الفاضل fzsss ولكن الكود بطئ جداً ونفس المشكلة ينسخ معلومات الموظف كاملة كأرقام وليس معادلات هل تقصد في ورقة المنقولون أم ورقة البيانات ؟ أنا مجرب الكود ينسخ المعادلات في كلا الورقتين في حالة نسخ الموظف الى ورقة المنقولون وفي حالة نسخ البيانات التاليه الى الصف المرحل ومايليه في ورقة البيانات أرجو التأكد من عمل الكود إلى أن أعدل على الكود لبطئه فعلا أو استعبضه بكود اخر