عبدالله باقشير

السلام عليكم كل عام وانتم بخير تقبل الله منا ومنكم صالح الاعمال

وعليكم السلام ورحمة الله وبركاته اخي الفاضل/ رعد العزاني --------------حفظه ربي جزاك الله خيرا وكل عام وانتم بخير تقبل تحياتي وشكري

السلام عليكم استخدم الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim LastRow As Long On Error GoTo 1 LastRow = Range("E" & Rows.Count).End(xlUp).Row If Not Application.Intersect(Target, Range("E9", Cells(LastRow, "E"))) Is Nothing Then Cells(Target.Row, "F").Value = Now End If 1: End Sub

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

السلام عليكم Private Sub CommandButton1_Click() Dim iNx Dim Last As Long ''''''''''''''''''''''' If Len(Trim(Range("C6"))) = 0 Then Exit Sub ''''''''''''''''''''''' iNx = Me.Evaluate("MATCH(C6,H:H,0)") ''''''''''''''''''''''' Select Case IsError(iNx) Case True If MsgBox("هل تريد اضافة الكتاب الجديد" & vbCr & Range("C6").Value, vbYesNo + vbMsgBoxRight) = vbYes Then Last = Range("H" & Rows.Count).End(xlUp).Row + 1 Range("H" & Last).Resize(1, 4).Value = Range("C6").Resize(1, 4).Value MsgBox "تم بحمد الله " End If ''''''''''''''' Case False If MsgBox("هل تريد اضافة العدد " & vbCr & Range("C6").Value, vbYesNo + vbMsgBoxRight) = vbYes Then Last = iNx Range("J" & Last).Value = Val(Range("J" & Last)) + Val(Range("E6")) MsgBox "تم بحمد الله " End If End Select End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim LastRow As Long On Error GoTo 1 LastRow = Range("C" & Rows.Count).End(xlUp).Row If Not Application.Intersect(Target, Range("C9", Cells(LastRow, "C"))) Is Nothing Then Application.EnableEvents = False Cancel = True Range("C6").Resize(1, 4).Value = Target.Resize(1, 4).Value 1: Application.EnableEvents = True End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = Range("C6").Address Then kh_AdFilter Me.CommandButton1.Enabled = Len(Trim(Range("C6"))) End If End Sub Private Sub kh_AdFilter() Dim RngFilte As Range Dim LastRow As Long LastRow = Range("H" & Rows.Count).End(xlUp).Row Range("H9", Cells(LastRow, "K")).AdvancedFilter xlFilterCopy, Range("M1:M2"), Range("C9:F9") End Sub شاهد المرفق 2003-2007 بحث واضافة.rar

جزاك الله خيرا ---------------------------------- جرب الكود المعدل في المرفق وهو نفس الكود في المشاركة 8 وعلشان تجرب الكود مع اكسل 2003 -2007 PROG.rar

انا مشيت على الطلب ولكن عملت حسابي لهذا السؤال ==================== مارايك لو الكود ياخذ امتداد الملف تلقائيا من نوع الملف النشط يعني الذي فيه زر انشاء ملف مع ملاحظة : اذا كنت تعمل على 2003 لازم يكون معاك نسخة من ملف Form بنفس الامتداد 2003 تفضل الكود: Option Explicit '////////////////////////////////////////////////////// ' اسم الملف الناسخ Const iNm As String = "Form" '////////////////////////////////////////////////////// Dim Wo As Workbook Dim iName As String Dim FilName As String Dim nPath As String Dim oPath As String Dim MyTyp As String '////////////////////////////////////////////////////// '////////////////////////////////////////////////////// Sub kh_BookChange() '============================ Dim ch As String * 1 ch = Application.PathSeparator '============================ On Error GoTo Err_kh_Files '============================ With ThisWorkbook MyTyp = Mid$(.Name, InStrRev(.Name, ".")) End With '============================ FilName = CStr(Range("B3")) iName = CStr(Range("C3")) oPath = CStr(Range("A3")) & ch & FilName & ch & iNm & MyTyp '============================ If Dir(oPath) = "" Then MsgBox "الملف : " & iNm & vbCr & "غير موجود" Exit Sub End If '============================ nPath = CStr(Range("A3")) & ch & FilName & ch & iName & MyTyp '============================ If Not Dir(nPath) = "" Then If MsgBox("أن هذا الملف موجود مسبقا هل تود استبداله ؟", vbYesNo, iName) = vbNo Then Exit Sub End If Else If MsgBox("أن هذا الملف غير موجود مسبقا هل تود اضافته ؟", vbYesNo, iName) = vbNo Then Exit Sub End If End If '============================ kh_CopyBook '============================ Err_kh_Files: If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear '============================ Set Wo = Nothing End Sub Sub kh_CopyBook() On Error GoTo Err_kh_kh_CopyBook kh_Application False '''''''''''''''''''''' Set Wo = Workbooks.Open(oPath) With Wo .Worksheets(1).Name = iName .Worksheets(1).Range("C5").Value = iName .SaveCopyAs nPath .Close False End With MsgBox ("تم بحمد الله حفظ الملف : " & vbCr & vbCr & oPath) ''''''''''''''''''''''' Err_kh_kh_CopyBook: kh_Application True End Sub Sub kh_Application(mbol As Boolean) With Application .DisplayAlerts = mbol .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub

السلام عليكم جرب الكود التالي: Option Explicit '////////////////////////////////////////////////////// ' اسم الملف الناسخ Const iNm As String = "Form.xlsm" '////////////////////////////////////////////////////// Sub kh_BookChange() Dim Wo As Workbook Dim sh As Worksheet Dim iName As String, FilName As String Dim nPath As String, oPath As String Dim ch As String * 1 ch = Application.PathSeparator '============================ On Error GoTo Err_kh_Files '============================ Set sh = ThisWorkbook.ActiveSheet FilName = CStr(Range("B3")) iName = CStr(Range("C3")) & ".xlsm" nPath = CStr(Range("A3")) & ch & FilName & ch & iName '============================ '============================ If Not Dir(nPath) = "" Then If MsgBox("أن هذا الملف موجود مسبقا هل تود استبداله ؟", vbYesNo, iName) = vbYes Then oPath = CStr(Range("A3")) & ch & FilName & ch & iNm If Not Dir(oPath) = "" Then '''''''''''''''''''''' kh_Application False '''''''''''''''''''''' Set Wo = Application.Workbooks.Open(oPath) With Wo .Worksheets(1).Name = sh.Range("C3").Value .Worksheets(1).Range("C5").Value = sh.Range("C3").Value .SaveCopyAs nPath .Close False MsgBox "تم بحمد الله " End With Else MsgBox "الملف : " & iNm & vbCr & "غير موجود" End If End If End If '============================ '============================ Err_kh_Files: kh_Application True If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear '============================ Set Wo = Nothing: Set sh = Nothing End Sub Sub kh_Application(mbol As Boolean) With Application .DisplayAlerts = mbol .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub واشعرنا بالنتيجة

اكيد لان باقي الصفوف المدموجة بدون قيم اصلا الحل: اترك الدمج وكرر القيمة في الصفوف التي كانت مدموجة ستعمل معاك الفلترة بكل بساطة والله اعلم

السلام عليكم تم تسمية الاوراق من عنوان العمود ليتم تطبيق معادلة واحده لكل جدول المعادلة الاولى: لفحص الدخول: =IF(ISERROR(MATCH($A3;OFFSET(INDIRECT(ADDRESS(1;1;;;B$2));;;1000;1);0));"لم يدخل";"دخل") المعادلة الثانية: لاظهار الدرجة حسب نتيجة المعادلة الاولى "دخل" =IF(B3="دخل";INDIRECT(ADDRESS(MATCH($A3;OFFSET(INDIRECT(ADDRESS(1;1;;;F$2));;;1000;1);0);2;;;F$2));"") المرفق 2003-2007 ربط جداول من اوراق اخرى.rar

زيادة في الخير

السلام عليكم تفضل: Sub Macro1() Dim dd As Range If Range("E1") = 1 Then Set dd = Range("A5:A10") Else Set dd = Range("B5:B10") End If '''''''''''''''''''''' dd.Copy Range("C5").PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم هذا كود منقول يعمل اختصار للملف على سطح المكتب عدلت عليه ليكون تلقائي للملف النشط قد يناسبك تفضل الكود: Sub CreateDesktopShortcut() Dim objShell As Object, wsh As Object Dim StrFilePath, newLnk, strDeskPath, strName ''''''''''''''''''' StrFilePath = ThisWorkbook.FullName '''''''''''''''''''' Set objShell = CreateObject("Shell.Application") Set wsh = CreateObject("WScript.Shell") ''''''''''''''''''''''''''' strDeskPath = objShell.Namespace(&H10&).Self.Path strName = strDeskPath & "\Shortcut to " & ThisWorkbook.Name & ".lnk" ' '''''''''''''''''''' Set newLnk = wsh.CreateShortcut(strName) newLnk.TargetPath = StrFilePath newLnk.Save Set objShell = Nothing Set wsh = Nothing End Sub

السلام عليكم استخدم الحدث ComboBox1_Click Private Sub ComboBox1_Click() LastRow = Cells(Rows.Count, "c").End(xlUp).Row + 1 Cells(LastRow, 3).Value = ComboBox1 Me.ComboBox1.ListIndex = -1 End Sub

جرب هذه =IF(AND(LEN(TRIM($M3))=0;COUNTIF($C$2:C2;"الإجمالي")=0);"الإجمالي";$M3)

السلام عليكم ضع المعادلة ادناه في الخلية سي 3 واسحبها على باقي خلايا العمود سي =IF($C2="ديسمبر";"الإجمالي";$M3) ودمتم في حفظ الله

السلام عليكم غير الرقم في المتغير tm حسب ما يناسبك من التوقيت بالزيادة او النصان Private Const Tm As Long = 5000 ''''''''''''''''''''''''''''''''' Private iii As Integer Private Sub ButtonRun_Click() Dim i As Integer Dim ii As Long '''''''''''''''''''''''''''' Me.ButtonRun.Enabled = False '''''''''''''''''''''''''''' If iii = 1 Then Me.OptB_1.BackStyle = 0: iii = 15 '''''''''''''''''''''''''''' For i = iii To 1 Step -1 Me.Controls("OptB_" & iii).BackStyle = 0 Me.Controls("OptB_" & i).BackStyle = 1: iii = i For ii = 1 To Tm DoEvents If Me.ButtonRun.Enabled = True Then Exit Sub Next Next '''''''''''''''''''''''''''' Me.OptB_1.BackStyle = 0 Me.ButtonRun.Enabled = True End Sub Private Sub UserForm_Activate() iii = 15 End Sub Private Sub UserForm_Click() Me.ButtonRun.Enabled = True End Sub المرفق 2007 Million2.rar

السلام عليكم ممكن لكن الموجود حاليا الادخال يدويا عبر مربعات نص الملف المرفق سابقا ودمتم في حفظ الله

السلام عليكم يمكنك اضافة اكثر من كود لاي جداول في الملف باستخدام مثل الكود ادناه فقط يتم تغيير اسم الكود والاعدادات للورقة والنطاق Option Explicit '====================================================== '====================================================== ' اسم ورقة البيانات Private Const Sh1 As String = "ورقة1" '------------------------------------------------------ ' نطاق صف رؤوس الاعمدة Private Const Rn1 As String = "B7:O7" '====================================================== '====================================================== Sub kh_Show_UFormChang() On Error GoTo 1 With UFormChang .kh_SetAddrss Sh1, Rn1 .Show End With 1: End Sub مع ملاحظة انه ليس له علاقة بالتسلسل اي لا يخل عمود التسلسل من ضمن البيانات المرفق 2003 قاعدة بيانات المدرسين.rar

السلام عليكم في احد الوحدات النمطية العامة تصرح عنه بالتعليمة Public Public MyName As String

السلام عليكم تجعل مصدر القائمة في قاعدة التحقق من صحة البيانات معادلة اتوماتيكية تحسب عدد صفوف النطاق حسب القيم الموجودة =OFFSET($I$8;;;COUNTA($I$8:$I$29);1) ودمتم في حفظ الله

السلام عليكم عدلنا نفس الكود الذي في ملفك جرب Sub copy1() Dim Wo As Workbook Dim Sh As Worksheet Dim Ayadah As String, Extension As String, savePathName As String ''''''''''''''' If Cells(2, 4) = "" Or Cells(2, 5) = "" Then MsgBox "No Name ", vbOKOnly, "Info!": Exit Sub ' اسم المجلد Ayadah = Cells(2, 5) ''''''''''''''''''' ' اسم الملف Extension = Cells(2, 4) & ".xls" '''''''''''''''' ' مسار الحفظ savePathName = "D:\" & Ayadah & "\" ''''''''''''''''''' ' ورقة النسخ Set Sh = ActiveSheet ''''''''''''''''''''' Sh.Copy Set Wo = ActiveWorkbook On Error Resume Next Application.DisplayAlerts = False GetAttr (savePathName) Select Case Err.Number Case Is = 0 Application.DisplayAlerts = False Wo.SaveCopyAs savePathName & Extension MsgBox "Project name exists and invoice saved in!", vbOKOnly, "Info!" Case Else MkDir savePathName Wo.SaveCopyAs savePathName & Extension MsgBox "Project name was created and invoice saved in", vbOKOnly, "Info!" End Select On Error GoTo 0 '''''''''''''''''''''''''' Wo.Close False Application.DisplayAlerts = True Set Wo = Nothing Set Sh = Nothing End Sub

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

Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim R As Integer If Not Intersect(Target.Cells(1, 1), Union(Range("D18:D39"), Range("F18:F39"), Range("O18:O39"))) Is Nothing Then R = Target.Row If Cells(R, "D").Value <> "" Then Cells(R, "C").Value = R - 17 Cells(R, "G").Value = Val(IIf(Cells(R, "O") <> "", Cells(R, "O"), Cells(R, "N"))) Cells(R, "H").Value = Val(Cells(R, "F")) * Val(Cells(R, "G")) Cells(R, "N").Value = WorksheetFunction.VLookup(Cells(R, "D"), [prices], 3, 0) Cells(R, "P").Value = WorksheetFunction.VLookup(Cells(R, "D"), [prices], 4, 0) Cells(R, "Q").Value = (Val(Cells(R, "G")) - Val(Cells(R, "P"))) * Val(Cells(R, "F")) Else Union(Cells(R, "C"), Cells(R, "H"), Cells(R, "N"), Cells(R, "P"), Cells(R, "Q")).ClearContents End If kh_Formula2 End If On Error GoTo 0 End Sub Private Sub kh_Formula2() Range("I10").FormulaR1C1 = "=IF(RC[-4]="""","""",VLOOKUP(RC[-4],address,3,0))" Range("I10").Value = Range("I10").Value Range("I12").FormulaR1C1 = _ "=SUMPRODUCT((الوكلاء!R5C5:R2002C5<=R8C5)*(الوكلاء!R5C4:R2002C4=R[-2]C[-4])*(الوكلاء!R5C8:R2002C8))" Range("I12").Value = Range("I12").Value End Sub