ياسر خليل أبو البراء

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

أخي الكريم ممكن تكبر حجم الخط شوية بالنسبة لطلبك روح للإجراء المسمى Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) في السطر الأخير قبل نهاية الإجراء وضع السطر التالي TextBox1.SetFocus بس خلاص

أخي الحبيب الشهابي لا أعتقد أن هذا هو المطلوب قم بالإطلاع على المرفق التالي لعل الأمور تكون أوضح Public Function GetItemTestCount(ItemTest As String, Criteria As String) As Long Dim Sht As Excel.Worksheet Dim Arr, lRow Dim Tally As Long, Count As Long Arr = Array("يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Application.Volatile Tally = 0 For Each Sht In ThisWorkbook.Worksheets If UBound(Filter(Arr, Sht.Name)) > -1 Then lRow = Application.WorksheetFunction.Match(ItemTest, Sht.Range("'" & Sht.Name & "'!$A$5:$A$500"), 0) + 4 If Criteria <> vbNullString Then Count = Application.WorksheetFunction.CountIf(Sht.Range("C" & lRow & ":" & "AG" & lRow), Criteria) Tally = Tally + Count End If Next GetItemTestCount = Tally End Function تقبل تحياتي Ehsaa UDF Function.rar

السلام عليكم أخي الكريم هلا وضحت الرموز في أوراق العمل a - f - j - b إلخ الرموز ...

إليك التعديل التالي Private Sub CommandButton1_Click() Dim LColor On Error GoTo Error If TextBox1 = "" Then MsgBox ("أدخل نص في حقل البحث") Else Cells.Find(What:=TextBox1, After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate LColor = ActiveCell.Interior.Color ActiveCell.Interior.Color = vbYellow Application.Wait (Now + TimeValue("0:00:01")) ActiveCell.Interior.Color = LColor End If Exit Sub Error: MsgBox ("لا تتوفر نتائج للبحث") End Sub

وعليكم السلام أخي الغالي ابو يوسف يشرفني ويسعدني دائماً مرروك العطر بالموضوع وأتمنى متابعتك الدائمة له إن شاء المولى بالنسبة للتحديث فهو أمر وارد وضروري ولكن لن يكون هناك فورمات للهاردوير (ربنا يخليك ويديك الصحة والعافية) .. فقط بعض التحديثات في السوفت وير والجهاز يشتغل طلقة ولا أحسنها جهاز من الأجهزة الحديثة (الأصلي أصلي) تقبل تحياتي ومداعبتي لك

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

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

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

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

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

أخي الحبيب لما حملت الملف وجدت الكود موجود بالفعل ويعمل كما تريد Private Sub TextBox1_AfterUpdate() If TextBox1.Text > Format(Date, "dd/mm/yyyy") Then TextBox2.Text = "العقد ساري المفعول" Else TextBox2.Text = "العقد منتهي" End If End Sub ما المشكلة إذاً ؟

أخي الكريم يرجى تغيير اسم الظهور للغة العربية بالنسبة للمبلغ الكلي والمدفوع .. لأني لا أقهم في المحاسبة ؟ هل تقصد عمود الدائن والمدين ؟ أم أن لها حساب خاص بها

إليك الطلب الأول Sub ConvertFormulaVBA() Dim LR As Long LR = Cells(Rows.Count, "D").End(xlUp).Row With Range("R8:R" & LR) .Formula = "=(T8*V8)/U8" .Value = .Value End With With Range("S8:S" & LR) .FormulaArray = "=Wish(D8:R" & LR & ",X12:Y23,3,14,15,10)" .Value = .Value End With End Sub بحيث لا تحدد آخر صف بنفسك بالنسبة للطلب الثاني إليك الكود Sub YasserKhalil() Dim rngData As Range, rngToCopy As Range, arrFilter, I As Long, J As Long Application.DisplayAlerts = False Application.ScreenUpdating = False If Len(Dir(ThisWorkbook.Path & "\Results", vbDirectory)) = 0 Then MkDir ThisWorkbook.Path & "\Results" End If Set rngData = Range("D7:S" & Cells(Rows.Count, "D").End(xlUp).Row) arrFilter = Application.Transpose(Range("X12:X" & Cells(Rows.Count, "X").End(xlUp).Row)) ReDim Preserve arrFilter(1 To UBound(arrFilter) + 1) arrFilter(UBound(arrFilter)) = "<>بدون توجيه" For I = 1 To UBound(arrFilter) ActiveSheet.AutoFilterMode = False rngData.AutoFilter Field:=16, Criteria1:=arrFilter(I) J = rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count If J = 1 Then GoTo skipper Set rngToCopy = Intersect(Union(Columns("D:E"), Columns("R:S")), rngData.SpecialCells(xlCellTypeVisible)) Workbooks.Add With ActiveSheet.Cells .Clear .FormatConditions.Delete End With rngToCopy.Copy Range("B5").PasteSpecial xlPasteValues Columns(2).ColumnWidth = 11: Columns(3).ColumnWidth = 28: Columns(4).ColumnWidth = 10.5: Columns(5).ColumnWidth = 15 With Range("B2:E3") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .MergeCells = True .Font.Size = 20 .Value = IIf(I < UBound(arrFilter), arrFilter(I), "قوائم التوجهات الكلية") End With If I < UBound(arrFilter) Then Columns("E").Delete FormatRange ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & arrFilter(I) & ".xlsx" Else FormatRange ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & "قوائم التوجهات الكلية" & ".xlsx" End If ActiveWorkbook.Close skipper: Next I ActiveSheet.AutoFilterMode = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub FormatRange() With Range("B5").CurrentRegion .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 13 .Borders.Weight = xlThin .BorderAround Weight:=xlThick End With Range("B2").Select End Sub إذا كان فيه أي طلبات أخرى يرجى طرح موضوع جديد حيث أنه يفضل أن يكون كل موضوع لطلب واحد فقط ... وصل الموضوع هنا إلى 4 طلبات ( ......................)

تسلم أخي الحبيب مختار على هذا الكود الجميل والرائع ممكن نختصره شوية (معلش رخم أنا ولازم أضع لمساتي اللي ملهاش لازمة في معظم الأحيان) Sub TestArray() Dim Arr(1 To 5, 4 To 7, 10, 1 To 9) MsgBox "The Number Of Dimensions For The Array " & ElementCount(Arr) End Sub Function ElementCount(B As Variant) As Long Dim V As Variant, Z As Long For Each V In B Z = Z + 1 Next V Do ElementCount = ElementCount + 1 Z = Z / (UBound(B, ElementCount) - LBound(B, ElementCount) + 1) Loop Until Z = 1 End Function

جرب أوفيس 2013 أفضل بكثير من 2007 و من 2010 ولا يوجد به مشاكل

أخي الكريم أشرف إليك الكود التالي عله يفي بالغرض Sub ConvertFormulaVBA() Dim LR As Long LR = Cells(Rows.Count, "D").End(xlUp).Row With Range("R8:R" & LR) .Formula = "=(T8*V8)/U8" .Value = .Value End With With Range("S8:S" & LR) .FormulaArray = "=Wish(D8:R27,X12:Y23,3,14,15,10)" .Value = .Value End With End Sub

جرب الكود التالي ..أدرج موديول جديد وضع فيه الكود التالي Private Type POINTAPI X As Long Y As Long End Type Private Type MOUSEHOOKSTRUCT pt As POINTAPI hwnd As Long wHitTestCode As Long dwExtraInfo As Long End Type Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long Private Const WH_MOUSE_LL As Long = 14 Private Const WM_MOUSEWHEEL As Long = &H20A Private Const HC_ACTION As Long = 0 Private Const GWL_HINSTANCE As Long = (-6) Private Const WM_KEYDOWN As Long = &H100 Private Const WM_KEYUP As Long = &H101 Private Const VK_UP As Long = &H26 Private Const VK_DOWN As Long = &H28 Private Const WM_LBUTTONDOWN As Long = &H201 Private mLngMouseHook As Long Private mListBoxHwnd As Long Private mbHook As Boolean Sub HookListBoxScroll() Dim lngAppInst As Long Dim hwndUnderCursor As Long Dim tPT As POINTAPI GetCursorPos tPT hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y) If mListBoxHwnd <> hwndUnderCursor Then UnhookListBoxScroll mListBoxHwnd = hwndUnderCursor lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE) PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0& If Not mbHook Then mLngMouseHook = SetWindowsHookEx( _ WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0) mbHook = mLngMouseHook <> 0 End If End If End Sub Sub UnhookListBoxScroll() If mbHook Then UnhookWindowsHookEx mLngMouseHook mLngMouseHook = 0 mListBoxHwnd = 0 mbHook = False End If End Sub Private Function MouseProc( _ ByVal nCode As Long, ByVal wParam As Long, _ ByRef lParam As MOUSEHOOKSTRUCT) As Long On Error GoTo errH If (nCode = HC_ACTION) Then If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then If wParam = WM_MOUSEWHEEL Then MouseProc = True If lParam.hwnd > 0 Then PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0 Else PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0 End If PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0 Exit Function End If Else UnhookListBoxScroll End If End If MouseProc = CallNextHookEx( _ mLngMouseHook, nCode, wParam, ByVal lParam) Exit Function errH: UnhookListBoxScroll End Function ثم في حدث الفورم أضف الكود التالي Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) HookListBoxScroll End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) UnhookListBoxScroll End Sub

تفضل الكود التالي في موديول جديد ضع الكود Sub MaleFemaleSequence() Static vMale As Variant Static vFemale As Variant Select Case Range("B6").Value Case "ذكر" If IsEmpty(vMale) Then vMale = 1 Else vMale = vMale + 2 If vMale > 9 Then vMale = 1 End If Range("C6") = vMale Case "أنثي" If IsEmpty(vFemale) Then vFemale = 0 Else vFemale = vFemale + 2 If vFemale > 8 Then vFemale = 0 End If Range("C6") = vFemale End Select End Sub ثم في حدث ورقة العمل ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$B$6" Then Exit Sub MaleFemaleSequence End Sub Male Female.rar

المشكلة سببها أن الملف تم عمله على نسخة أوفيس أحدث مما لديك جرب تنصب أحدث نسخة وإن شاء الله لن تجد المشكلة ...

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

الموضوع بسيط بالشكل ده كليك يمين على الخلايا المراد إنها تكون فيها هذه الميزة ثم Format cells ثم التبويب Alignment وعلم علامة صح على الخيار Wrap Text بس خلاص

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

أخي الحبيب مختار عادةً لا يتم استخدام المصفوفات الأكثر من الأبعاد الثنائية .. بصرف النظر عن عدد الصفوف أو الأعمدة المصفوفة الثنائية مرتبطة ببعدين فقط ..بعد الصفوف مهما كما عددها وبعد الأعمدة مهما كان عددها .. أما بالنسبة للمصفوفة ثلاثية الأبعاد جرب الكود التالي اضغط F8 وشوف نافذة الـ Locals Sub Test() Dim arr(1 To 3, 1 To 5, 1 To 4) End Sub هتلاقي البعد الأول مكون من 3 عناصر وتحت كل عنصر يقع البعد الثاني المكون من 5 عناصر وتحت كل عنصر من العناصر الخمسة يوجد عناصر البعد الثالث والمكون من 4 عناصر لا تهتم بالمصفوفات ذات الأبعاد الأكثر من اثنين الأكثر استخداماً هي المصفوفات الأحادية والثنائية فقط

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