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

السلام عليكم جرب هذا Sub kh_Delete() Dim Rng As Range, cel As Range, ArRng As Range '''''''''''''''''''''''' Set Rng = Range("A2:A1000") '''''''''''''''''''''''' For Each cel In Rng If IsEmpty(cel) Then GoTo 1 If WorksheetFunction.CountIf(Rng, cel) > 1 Then If ArRng Is Nothing Then Set ArRng = cel Else Set ArRng = Union(ArRng, cel) End If 1: Next If Not ArRng Is Nothing Then ArRng.Delete Set Rng = Nothing Set ArRng = Nothing End Sub

السلام عليكم حسب ما فهمت بالمعادلات النطاق kh_date هو الخلايا =ورقة3!$B$2:$K$367 هذه المعادلة =SUMPRODUCT((INDEX(kh_date;0;1)>=$C$2)*(INDEX(kh_date;0;1)<=$C$3);INDEX(kh_date;0;$B6+1)) شاهد المرفق 2003 استدعاء بيانات.rar

السلام عليكم الكود التالي يعمل على 2003-2007 Option Explicit '////////////////////////////////////////////////////// ' اسم مجلد الملفات Const FilName As String = "ملفاتي" ' عنوان خلية الجمع في الملفات Const Adr As String = "A1" '////////////////////////////////////////////////////// Sub kh_SumAllBook() Dim MyObj, MyObjFol, Obj Dim xlw As Excel.Workbook Dim MySheet As Worksheet Dim iPath As String, iName As String Dim Last As Long, i As Long Dim ch As String * 1 ch = Application.PathSeparator '============================ On Error GoTo Err_kh_Files '============================ iPath = ActiveWorkbook.Path & ch & FilName & ch Set MyObj = CreateObject("Scripting.FileSystemObject") Set MyObjFol = MyObj.GetFolder(iPath) '============================ Set MySheet = ThisWorkbook.Worksheets("TOTAL") '============================ With MySheet Last = .Cells(Rows.Count, "A").End(xlUp).Row .Range("A2").Resize(Last, 3).ClearContents End With '============================ kh_Application False '============================ On Error Resume Next For Each Obj In MyObjFol.Files iName = Obj.Path If Not Dir(Obj.Path) = "" Then If TestType(CStr(Obj.Name)) Then Set xlw = Workbooks.Open(iName) With MySheet i = i + 1 .Cells(i + 1, "A").Value = CStr(Obj.Name) .Cells(i + 1, "B").Value = CStr(xlw.Worksheets(1).Name) .Cells(i + 1, "C").Value = Val(xlw.Worksheets(1).Range(Adr)) End With xlw.Close False End If End If Next On Error GoTo 0 '============================ If i Then MySheet.Range("E2").Value = Evaluate("Sum(" & Range("C2").Resize(i).Address & ")") '============================ Err_kh_Files: kh_Application True If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear '============================ Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing End Sub Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub Function TestType(MyTName As String) As Boolean Dim MyTyp As String MyTyp = Mid$(MyTName, InStrRev(MyTName, ".")) TestType = MyTyp Like ".xls*" End Function المرفق 2003-2007 kh_sum.rar

السلام عليكم اتريده بالكود هنا يمكنك تعيين المدى الذي تريده Private Const stRng As String = "B4:B100" Option Explicit Private Const stRng As String = "B4:B100" Private Sub Worksheet_Change(ByVal Target As Range) If Me.CheckBox1.Value = True Then Exit Sub On Error Resume Next If Not Intersect(Target.Cells, Range(stRng).Cells) Is Nothing Then If Target.Cells.Count > 1 Then Exit Sub If Application.CountIf(Range(stRng), Target.Value) > 1 Then Application.EnableEvents = False Application.Undo If Application.CountIf(Range(stRng), Target.Value) > 1 Then Target.ClearContents Application.EnableEvents = True MsgBox "مكرر " End If End If On Error GoTo 0 End Sub المرفق 2003 WORK SHOP INVENTORY.rar

وعليكم السلام انت صعبتها على نفسك وعلى غيرك ممن يريدوا مساعدتك لو الطلب واضح كان وجدت اكثر من اجابة مرة اخرى تلون المطلوب ايجاده للفصل 1 بلون معين في ورقة 3 فصول وتلون اماكنها في ورقة الفصل 1 بنفس اللون وتكرر العملية لباقي الفصول بالوان اخرى ان شاء الله تنجح هذه الطريقة في الفهم

كود التصفية Sub SRCH() Range("input").AdvancedFilter xlFilterInPlace, Range("ORDER") End Sub كود اظهار الكل Sub kh_AllData() With ActiveSheet If .FilterMode Then .ShowAllData End With End Sub المرفق 2003-2007 H2.rar

لماذا الدمج ؟؟ بدلا من الدمج في الخلايا من القائمة تنسيق خلايا محاذاة محاذاة النص افقي توسيط ممتد عبر التحديد جرب واخبرنا بالنتيجة

السلام عليكم هناك لبس في فهم الطلب ولم الاحظ اختلاف فورمات الارقام بين الكودين عذرا هذا التعديل حسب طلبك ان شاء الله Private Sub Worksheet_Change(ByVal Target As Range) Dim ce As Range If Intersect(Target, Range("D5:P141")) Is Nothing Then Exit Sub ''''''''''''''''''''''''''''''''''''''' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ''''''''''''''''''''''''''''''''''''''' For Each ce In Range("D5:AH141") If Not IsNumeric(ce) Then GoTo 1 With ce If Not Intersect(ce, Range("D5:P141")) Is Nothing Then .NumberFormat = "_(#,##_);[Red]_((#,##);_(--_);_(@_)" Else .NumberFormat = "_(#,##0.00_);[Red]_((#,##0.00);_(--_);_(@_)" End If .HorizontalAlignment = IIf(.Value, xlRight, xlCenter) .VerticalAlignment = xlCenter End With 1: Next '''''''''''''''''''''''''''''''' Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ''''''''''''''''''''''''''''''' End Sub

الحمدلله رب العالمين

جزاك الله خيرا ما فائدة هذه المعادلة في معيار التصفية =COUNTIF($C$2:$C$151;Sheet1!E2)<>0 هذا هو المعيار الخلية Sheet1!E2 هي اول خلية في نطاق النسخ من عمود المراكز لو فرضنا انك سحبت الخلية اللي فيها المعادلة بعدد صفوف نطاق النسخ ستعطيك قيم مختلفة TRUE او FALSE الصف اللي فيه القيمة TRUE هو اللي بلصق في نتيجة التصفية مع ملاحظة ان المعادلة التي تشير اللى الخلية في نطاق النسخ وهي Sheet1!E2 يجب ان تكون نسبية وليست مطلقة علشان تسحب في المعيار --------------------------------------------------- ممكن تكون فاضية او مكتوب فيها اي شي مثلا المعيار اساسا الكود لا ياخذ اسم العمود منها وانما من المعادلة فقط ولكن يجب تضمينها في نطاق المعيار في الكود ان شاء الله يكون الشرح واضح ودمتم في حفظ الله

وعليكم السلام اريد ان اعرف كيف جربت الكود في النطاق R5:AH141 المدى هذا فيه معادلات !!!!!!!!!!! ------------------------------------ طريقة عمل الكود هي : اذا غيرت اي قيمة في المدى D5:P137 سيعمل الكود في خلية الادخال و جميع المعادلات في المدى D5:AH141 جرب واخبرنا بالنتيجة

تعرف تسجل كود ؟ اذا الاجابة نعم وانت في ورقة الترحيل اضغط تسجيل كود من القائمة ملف اعدادات الصفحة غير اي شي ثم اعمل ايقاف التسجيل ستحصل على كود باعدادات الورقة مثل هذا: Sub ماكرو1() ' ' ماكرو2 ماكرو ' الماكرو مسجل ‎02/10/2012 بواسطة ‎BaQuShEeR ' With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With ActiveSheet.PageSetup.PrintArea = "$B$3:$I$34" With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "&G" .RightHeader = "" .LeftFooter = "" .CenterFooter = "&D" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.196850393700787) .RightMargin = Application.InchesToPoints(0.393700787401575) .TopMargin = Application.InchesToPoints(3.1496062992126) .BottomMargin = Application.InchesToPoints(0.748031496062992) .HeaderMargin = Application.InchesToPoints(0.31496062992126) .FooterMargin = Application.InchesToPoints(0.31496062992126) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .CenterHorizontally = True .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = 108 .PrintErrors = xlPrintErrorsDisplayed End With End Sub ثم غير اسم الكود مثلا : kh_PageSetup ضع الاسم هذا في الكود kh_AddDate بعد السطر Application.CutCopyMode = False حاول واخبرنا النتيجة

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

من نافذة الفيجوال بيسك اسحب الفورم الى ملفك لنفرض ان ملفك Book1

السلام عليكم اضف هذا الكود مع الدالة الى ملفك واربطه بزر Sub kh_AddDate() Dim sh As Worksheet Dim MyRng As Range Dim MyName As String '''''''''''''''''' Set MyRng = Range("B3:I34") MyName = Range("K3").Value ''''''''''''''''''''' If kh_Test_MyChr(MyName) Then Exit Sub Range("K3").ClearContents '''''''''''''''' Set sh = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)) '''''''''''''''' sh.Name = MyName MyRng.Copy With sh.Range("B3") .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteFormats .PasteSpecial xlPasteValues End With '''''''''''''''''''''' Application.CutCopyMode = False Set sh = Nothing Set MyRng = 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 المرفق 2003 خطاب مطابقة.rar

بالنسبة لهذا السطر ما في داعي لتكراره .NumberFormat = "_(#,##_);[Red]_((#,##);_(--_);_(@_)" اعمل التنسيق هذا للرقم يدويا على جميع النطاق رايي انا ان تحذفه من الكود وهذا راجع اليك

السلام عليكم جرب هذا Private Sub Worksheet_Change(ByVal Target As Range) Dim ce As Range If Intersect(Target, Range("D5:P141")) Is Nothing Then Exit Sub ''''''''''''''''''''''''''''''''''''''' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ''''''''''''''''''''''''''''''''''''''' If IsNumeric(Target) Then kh_Format Target ''''''''''''''''''''''''''''''''''''''' For Each ce In Range("D5:AH141") If ce.HasFormula Then If IsNumeric(ce) Then kh_Format ce End If Next '''''''''''''''''''''''''''''''' Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ''''''''''''''''''''''''''''''' End Sub Private Sub kh_Format(ByVal Cel As Range) With Cel .NumberFormat = "_(#,##_);[Red]_((#,##);_(--_);_(@_)" .HorizontalAlignment = IIf(.Value, xlRight, xlCenter) .VerticalAlignment = xlCenter End With End Sub

شاهد المرفق 2003-2007 H1.rar

السلام عليكم في المرفق2007 تصفية بثلاثة معايير ملاحظة: قم بحذف العمود F هذا جعلته مؤقتا ترى المراكز المرحلة H.rar

السلام عليكم اخي الفاضل احمد غانم ---حفظه الله طلبك غير مفهوم بالمره والاوراق منسقة تنسيقات يصعب التعامل معها وخاصة الدمج ولا ندري اين العمود الذي نستدل به عن اسماء الفصول في شيت (ارصدة3 فصول) وهل تريده بالكود او بالمعادلات والله نود ان نساعدكم وتحز في انفسنا كلماتك الطيبة ودمتم في حفظ الله

الكود يحتاج تركيز اولا هذا يعمل تمام عندي ActiveCell.EntireRow.Delete جرب انت قبل الدخول الى الفورم لون السطر الذي تريد حذفه باي لون لان التركيز على الارقام بعد الحذف يضيع انتباهك ومن الفورم قم بحذفه ------------------------------------------------ ثانيا مفروض هذا السطر يولد رسالة خطا اذا كانت محتوى الخلية النشطة ليس رقما صحيحا وهذا قد يحدث Sub kh1() ورقة1.Activate MsgBox Rows(ActiveCell).Offset(1, 0).Address End Sub جرب الكود في ملف جديد -------------------------------------- ثالثا اذا في سطر بدون اسم يتجاوزه الجرار ويذهب الى السطر الاول جرب اذهب الى السطر 19

لحظة اشوف الملف

السلام عليكم راجع هذا السطر Rows(ActiveCell).Offset(1, 0).Delete Shift:=xlUp ' احذف الصف الموافق للخلبة النشطة هذا يحذف صف الخلية النشطة ActiveCell.EntireRow.Delete xlUp

المطلوب بالمعادلات المرفق2007 برنامج+ال...rar

السلام عليكم احسنت اخي الحبيب ابو حنين وبعد اذنك انا لدي فورم في ملفاتي الخاصة فيه من المطلوب الكثير المرفق 2003 فورم معاينة وتعديل و إضافة.rar