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

العفو اخي الفاضل

السلام عليكم تفضل: Private Sub Worksheet_Selectionchange(ByVal Target As Range) ''''''''''''''''''''''''''''''''''''''''''''''' ' في حالة الخطا يذهب الى السطر 1 On Error GoTo 1 ''''''''''''''''''''''''''''''''''''''''''''''' ' ايقاف تمكين الاحداث Application.EnableEvents = False ''''''''''''''''''''''''''''''''''''''''''''''' ' Target.EntireRow : كامل الصف للتحديد ' Target.EntireColumn : كامل العمود للتحديد ' Union : يُرجعُ إتحادُ خلايا ' Select : Union تحديد النطاق المجمع في Union(Target.EntireRow, Target.EntireColumn).Select ''''''''''''''''''''''''''''''''''''''''''''''' ' تنشيط الخلية المحددة Target.Activate 1: ''''''''''''''''''''''''''''''''''''''''''''''' ' تشغيل تمكين الاحداث Application.EnableEvents = True End Sub

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

السلام عليكم ابشر اخي الشهابي جاري التعديل ان شاء الله

السلام عليكم احسنت اخي ابوحنين نشيط ومثابر لفعل الخير كعادتك تقبل تحياتي وشكري

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

السلام عليكم هذا كود صممته هدية مني لك يقوم بانشاء الاورق داخل الملف Option Explicit Dim Rng As Range Dim NamSheet As String Sub kh_Add_Worksheets() Dim Sh As Worksheet Dim i As Long, Last As Long Dim Msg As String ''''''''''''''''''''''' On Error Resume Next With Sheets("kh") Last = .Cells(.Rows.Count, 1).End(xlUp).Row If Last < 6 Then GoTo kh_ExT Set Rng = Range("B6:U" & Last) End With ''''''''''''''''''''''' kh_Application False ''''''''''''''''''''''' With Rng.Offset(0, -1).Columns(1) For i = 1 To .Rows.Count NamSheet = Trim(.Cells(i, 1)) If Len(NamSheet) = 0 Then GoTo 1 NamSheet = kh_Replace(NamSheet) ''''''''''''''''''' If IsError(Evaluate("'" & NamSheet & "'!A1")) Then Set Sh = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)) Sh.Name = NamSheet kh_CopyRng Sh, .ColumnDifferences(.Cells(i, 1)) End If ''''''''''''''''''''' 1: Next .Worksheet.Activate End With ''''''''''''''''''''''' kh_ExT: kh_Application True ''''''''''''''''''''''' Set Sh = Nothing Set Rng = Nothing On Error GoTo 0 End Sub Sub kh_CopyRng(Sht As Worksheet, RngHidden As Range) RngHidden.EntireRow.Hidden = True ''''''''''''''''''''''''''''''''''''' Rng.SpecialCells(xlCellTypeVisible).Copy '''''''''''''''''''''''''''' With Sht.Range("A6") .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With ''''''''''''''''''''''''''''' RngHidden.EntireRow.Hidden = False ''''''''''''''''''''''''''''''''''''' 'نسخ رؤوس الاعمدة With Sht .Range("B1").Value2 = NamSheet Rng.Worksheet.Range("B2:U5").Copy With .Range("A2") .PasteSpecial xlPasteFormats .PasteSpecial xlPasteFormulas Application.CutCopyMode = False .Select End With End With ''''''''''''''''''''''''''''''''''''' End Sub Function kh_Replace(rName As String) As String Dim itm Dim myRep As String myRep = rName For Each itm In Array("/", "\", "*", ":", "؟", "?", "[", "]") myRep = Replace(myRep, itm, "") Next '''''''''''''''''''''''''''' myRep = Mid$(myRep, 1, 31) '''''''''''''''''''''''''''' kh_Replace = myRep End Function Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol End With End Sub المرفق 2003-2007 انشاء اوراق بحسابات العملاء.rar

السلام عليكم لائراء الموضوع فقط باستخدام دالة SUMPRODUCT =SUMPRODUCT((LEN(A2:A4)-LEN(SUBSTITUTE(A2:A4;TRIM($A$7);"")))/LEN(TRIM($A$7)))

السلام عليكم نورت المنتدى اخي رجب تقبل تحياتي وشكري

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

وبارك فيك ------------------ عند تسمية ورقة باسم لا تقبل في التسمية هذه الحروف لذا يجب تصفية الاسم من هذه الحروف حتى يعتمد الاسم الذي تريده بالضبط -------------------------------- ايضا من موانع التسمية ان لا تزيد احرف الاسم على 31 حرف وايضا اذا كان الاسم موجود من سابق والله اعلم ارجو ان شرحي واضح لديكم ودمتم في حفظ الله

السلام عليكم Option Explicit Sub kh_Add_Worksheets() Dim Sh As Worksheet Dim i As Long, iCont As Long Dim Nam As String ''''''''''''''''''''''' On Error Resume Next Set Sh = Sheets("kh") iCont = Sh.Cells(Rows.Count, 1).End(xlUp).Row ''''''''''''''''''''''' kh_Application False ''''''''''''''''''''''' For i = 2 To iCont Nam = kh_Replace(Sh.Cells(i, 1)) ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Nam Next Sh.Activate ''''''''''''''''''''''' kh_Application True ''''''''''''''''''''''' Set Sh = Nothing On Error GoTo 0 End Sub Function kh_Replace(rName As String) As String Dim itm Dim myRep As String myRep = rName For Each itm In Array("/", "\", "*", ":", "¿", "?", "[", "]") myRep = Replace(myRep, itm, "") Next kh_Replace = myRep End Function Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol End With End Sub المرفق 2003 اضافة صفحات من لست.rar

تفضل الكود التالي: Private Sub Worksheet_Selectionchange(ByVal Target As Range) On Error GoTo 1 Static xRng As Range Application.EnableEvents = False ''''''''''''''''''''''''''' If xRng Is Nothing Then Cells.Interior.ColorIndex = xlNone Else xRng.Interior.ColorIndex = xlNone End If '''''''''''''''''''''''''''' Set xRng = Union(Target.EntireRow, Target.EntireColumn) xRng.Interior.ColorIndex = 6 '''''''''''''''''''''''''''' 1: Application.EnableEvents = True End Sub

تقصد ميزان مراجعة ؟

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

السلام عليكم ممكن هذا افتراضا دي 5 الخلية المكتوب فيها اسم المورد Sub GO_TO11() Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets If sh.Name = CStr(Range("d5")) Then sh.Activate End If Next End Sub

هذا افضل لتجنب الخطا Private Sub Worksheet_Selectionchange(ByVal Target As Range) On Error GoTo 1 Application.EnableEvents = False Union(Target.EntireRow, Target.EntireColumn).Select Target.Activate 1: Application.EnableEvents = True End Sub

السلام عليكم هذا ملف حملته من المنتدى بعثه الاخ زياد حفظه الله فيه امكانيات كثيرة ومنها ما طلبت المرفق 2003 الترحيل لحسابات العملاء.rar

السلام عليكم تفضل الكود التالي: ضعه في حدث الورقة Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.Address = Range("N20").Address Then Union(Target.EntireRow, Target.EntireColumn).Select Target.Activate End If End Sub المرفق2003-2007 1.rar

ويسعدني ايضا قد يختلف استخدامها من جهاز وآخر والله اعلم

السلام عليكم عندي تطلع خطا هل عندك تطلع خطا؟؟؟

وجزاك خيرا اخي ابوحنين النشيط دوما ماشاء الله لاقوة الا بالله

المرفق 2003 حذف المكرر الاصل والمكرر.rar

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

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