نجوم المشاركات

قبل شهور كنت قد كتبت هدا الكود الدي يعطي للمستخدم امكانية التحكم في لون ال UserForm Title Bar و التحكم في حجم و لون و شكل ال Font أي الخط المكتوب به ال UserForm Caption كل حرف على حدى الكود لا يشتغل في اجهزة ال 64Bit Windows ملف للتحميل : https://app.box.com/s/l96isv4jal2rns144zy5 1- كود في Standard Module : Option Explicit Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Type PAINTSTRUCT hdc As Long fErase As Long rcPaint As RECT fRestore As Long fIncUpdate As Long rgbReserved(32) As Byte End Type Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * 32 End Type Private Type FontAttributes FONT_NAME As String FONT_SIZE As Long FONT_BOLD As Boolean FONT_ITALIC As Boolean FONT_UNDERLINE As Boolean End Type Private Type TRIVERTEX x As Long y As Long Red As Integer Green As Integer Blue As Integer Alpha As Integer End Type Private Type GRADIENT_RECT UpperLeft As Long LowerRight As Long End Type Private Declare Function CreateFontIndirect Lib "gdi32" _ Alias "CreateFontIndirectA" _ (lpLogFont As LOGFONT) As Long Private Declare Function GetWindowDC Lib "user32" _ (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" _ (ByVal hwnd As Long, _ ByVal hdc As Long) As Long Private Declare Function TextOut Lib "gdi32" _ Alias "TextOutA" _ (ByVal hdc As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal lpString As String, _ ByVal nCount As Long) As Long Private Declare Function SetBkMode Lib "gdi32" _ (ByVal hdc As Long, _ ByVal nBkMode As Long) As Long Private Declare Function SelectObject Lib "gdi32" _ (ByVal hdc As Long, _ ByVal hObject 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 UnhookWindowsHookEx Lib "user32" _ (ByVal hHook 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 GetCurrentThreadId Lib "kernel32" _ () As Long Private Declare Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function CallWindowProc Lib "user32" _ Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" _ Alias "GetClassNameA" _ (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Declare Function SetTextColor Lib "gdi32" _ (ByVal hdc As Long, _ ByVal crColor As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" _ (lpLogBrush As LOGBRUSH) As Long Private Declare Function FillRect Lib "User32.dll" _ (ByVal hdc As Long, _ ByRef lpRect As RECT, _ ByVal hBrush As Long) As Long Private Declare Function SetRect Lib "user32" _ (lpRect As RECT, _ ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function GetWindowRect Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpRect As RECT) As Long Private Declare Function BeginPaint Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpPaint As PAINTSTRUCT) As Long Private Declare Function EndPaint Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpPaint As PAINTSTRUCT) As Long Private Declare Function InvalidateRect Lib "User32.dll" _ (ByVal hwnd As Long, _ ByVal lpRect As Long, _ ByVal bErase As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" _ (ByVal nIndex As Long) As Long Private Declare Function SetMapMode Lib "gdi32" _ (ByVal hdc As Long, _ ByVal nMapMode As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _ (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _ lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias _ "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _ (dst As Any, ByVal iLen As Long) Private Declare Function GetTextColor Lib "gdi32" ( _ ByVal hdc As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As _ Long, ByVal y As Long) As Long Private Declare Function IsBadWritePtr Lib "kernel32" _ (ByVal lp As Long, ByVal ucb As Long) As Long Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" _ (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, _ pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long Private Declare Function PtInRect Lib "user32" _ (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Private Declare Function ScreenToClient Lib "User32.dll" _ (ByVal hwnd As Long, _ ByRef lpPoint As POINTAPI) As Long Private Declare Function DrawFrameControl Lib "user32" _ (ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long Private Declare Function OffsetRect Lib "user32" _ (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Private Const DFC_CAPTION = 1 Private Const DFCS_CAPTIONCLOSE = &H0 Private Const DT_CALCRECT = &H400 Private Const WH_CBT As Long = 5 Private Const HCBT_ACTIVATE As Long = 5 Private Const GWL_WNDPROC As Long = -4 Private Const WM_ACTIVATE As Long = &H6 Private Const WM_PAINT As Long = &HF& Private Const WM_SHOWWINDOW As Long = &H18 Private Const WM_EXITSIZEMOVE As Long = &H232 Private Const WM_DESTROY As Long = &H2 Private Const SM_CYCAPTION As Long = 4 Private Const COLOR_ACTIVECAPTION = 2 Private Const GRADIENT_FILL_RECT_H As Long = &H0 Private Const WM_SYSCOMMAND = &H112 Private Const SM_CXSIZE = 30 Private Const SM_CYSIZE = 31 Private Const WS_SYSMENU = &H80000 Private Const GWL_STYLE As Long = (-16) Private tFontAttr As FontAttributes Private tr2 As RECT Private tRect As RECT Private lPrevWnd As Long Private lhHook As Long Private bHookEnabled As Boolean Private oForm As Object Private bGradientFill As Boolean Private lCharColorsPtr As Long Private bCreateFont As Boolean Private lDefaultFontColor As Long Private sFontName As String Private lFontSize As Long Private bFontBold As Boolean Private bFontItalic As Boolean Public bFontUnderline As Boolean Private sCaptionText As String Private lTitleBarColor As Long Private lFontColour As Long Private aCharColors() As Variant Public Sub ShowFormatedUserForm( _ ByVal Form As Object, _ Optional ByVal TitleBarColor As Long, _ Optional ByVal GradientFill As Boolean, _ Optional ByVal FontAttributesPtr As Long, _ Optional CharColorsPtr As Long _ ) Call HookUserForm(ByVal Form, _ ByVal TitleBarColor, _ ByVal GradientFill, _ ByVal FontAttributesPtr, _ CharColorsPtr _ ) End Sub Private Sub HookUserForm _ (ByVal Form As Object, ByVal TitleBarColour As Long, _ ByVal GradientFill As Boolean, ByVal FontAttributesPtr As Long, _ CharColorsPtr As Long) If Not bHookEnabled Then Set oForm = Form sCaptionText = Form.Caption Form.Caption = vbNullString lCharColorsPtr = CharColorsPtr bGradientFill = GradientFill lTitleBarColor = IIf(TitleBarColour = 0, _ GetSysColor(COLOR_ACTIVECAPTION), TitleBarColour) lDefaultFontColor = IIf(CharColorsPtr = 0, GetSysColor(9), 0) If IsBadWritePtr(FontAttributesPtr, 4) = 0 Then If FontAttributesPtr <> 0 Then CopyMemory ByVal tFontAttr, ByVal FontAttributesPtr, LenB(tFontAttr) With tFontAttr sFontName = .FONT_NAME lFontSize = .FONT_SIZE bFontBold = .FONT_BOLD bFontItalic = .FONT_ITALIC bFontUnderline = .FONT_UNDERLINE End With bCreateFont = True Else bCreateFont = False End If End If If IsBadWritePtr(CharColorsPtr, 4) = 0 Then If CharColorsPtr <> 0 Then ReDim aCharColors(Len(sCaptionText)) CopyMemory aCharColors(0), ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1) ZeroMemory ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1) Else Erase aCharColors() End If End If lhHook = SetWindowsHookEx _ (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId) bHookEnabled = True Form.Show Else MsgBox "The hook is already set.", vbInformation End If End Sub Private Function HookProc _ (ByVal idHook As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim sBuffer As String Dim lRetVal As Long Dim lDc As Long If idHook = HCBT_ACTIVATE Then sBuffer = Space(256) lRetVal = GetClassName(wParam, sBuffer, 256) If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _ Left(sBuffer, lRetVal) = "ThunderXFrame" Then lDc = GetWindowDC(wParam) ReleaseDC wParam, lDc lPrevWnd = SetWindowLong _ (wParam, GWL_WNDPROC, AddressOf CallBackProc) UnhookWindowsHookEx lhHook bHookEnabled = False End If End If HookProc = CallNextHookEx _ (lhHook, idHook, ByVal wParam, ByVal lParam) End Function Private Function CallBackProc _ (ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Static i As Long Dim lDc As Long Dim lStyle As Long Dim loword As Long Dim hiword As Long Dim tPt As POINTAPI Dim x As Long Dim pt As POINTAPI Dim tr As RECT On Error Resume Next GetWindowRect hwnd, tRect Select Case Msg Case WM_PAINT, WM_ACTIVATE If Msg = WM_ACTIVATE Then lStyle = GetWindowLong(hwnd, GWL_STYLE) SetWindowLong hwnd, GWL_STYLE, (lStyle And Not WS_SYSMENU) End If lDc = GetWindowDC(hwnd) Call DrawTitleBar(hwnd, lTitleBarColor) SetBkMode lDc, 1 If bCreateFont Then CreateFont lDc End If For i = 1 To Len(sCaptionText) If lCharColorsPtr = 0 Then SetTextColor lDc, lDefaultFontColor Else SetTextColor lDc, aCharColors(i - 1) End If SetRect tr, 0, 0, 0, 0 DrawText lDc, Mid(sCaptionText, i, 1), _ Len(Mid(sCaptionText, i, 1)), tr, DT_CALCRECT If x = 0 Then x = 4 TextOut lDc, x, GetSystemMetrics(SM_CYCAPTION) / 3, _ Mid(sCaptionText, i, 1), Len(Mid(sCaptionText, i, 1)) x = x + Abs(tr.Right - tr.Left) Next lFontColour = GetTextColor(lDc) ReleaseDC hwnd, lDc InvalidateRect hwnd, 0, 0 Case WM_EXITSIZEMOVE, WM_SHOWWINDOW Call DrawTitleBar(hwnd, lTitleBarColor) InvalidateRect hwnd, 0, 0 Case WM_SYSCOMMAND GetHiLoword lParam, loword, hiword tPt.x = loword tPt.y = hiword ScreenToClient hwnd, tPt If PtInRect(tr2, tPt.x, -tPt.y) Then Unload oForm End If Case WM_DESTROY SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd bGradientFill = False lCharColorsPtr = 0 bCreateFont = False lDefaultFontColor = 0 sFontName = vbNullString lFontSize = 0 bFontBold = False bFontItalic = False bFontUnderline = False sCaptionText = vbNullString lTitleBarColor = 0 lFontColour = 0 Erase aCharColors() Set oForm = Nothing End Select CallBackProc = CallWindowProc _ (lPrevWnd, hwnd, Msg, wParam, ByVal lParam) End Function Private Sub CreateFont(DC As Long) Dim uFont As LOGFONT Dim lNewFont As Long With uFont .lfFaceName = sFontName & Chr$(0) .lfWidth = lFontSize .lfWeight = IIf(bFontBold, 900, 100) .lfItalic = bFontItalic .lfUnderline = bFontUnderline End With lNewFont = CreateFontIndirect(uFont) DeleteObject (SelectObject(DC, lNewFont)) End Sub Private Sub ConvertLongToRGB(ByVal Value As Long, r As Byte, g As Byte, b As Byte) r = Value Mod 256 g = Int(Value / 256) Mod 256 b = Int(Value / 256 / 256) Mod 256 End Sub Private Function LongToUShort(Unsigned As Long) As Double LongToUShort = CInt(Unsigned - &H10000) End Function Private Function TransfCol(ByVal Col As Long) As Double Dim a As Double If Col = 0 Then TransfCol = 0 ElseIf Col > 127 Then a = 256 - Col TransfCol = -(256 * a) Else a = Col TransfCol = 256 * a End If End Function Private Sub DrawTitleBar _ (lhwnd As Long, ByVal MyColor As Long) Dim tPS As PAINTSTRUCT Dim tLB As LOGBRUSH Dim tr As RECT Dim lDc As Long Dim l As Long Dim hBrush As Long Dim vert(2) As TRIVERTEX Dim tPt As GRADIENT_RECT Dim r As Byte, g As Byte, b As Byte Call BeginPaint(lhwnd, tPS) lDc = GetWindowDC(lhwnd) tLB.lbColor = MyColor hBrush = CreateBrushIndirect(tLB) Call GetWindowRect(lhwnd, tr) SetRect tr, 0, 0, tr.Right, tr.Bottom SetRect tr2, 0, 5, _ GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tr.Bottom OffsetRect tr2, tRect.Right - tRect.Left - GetSystemMetrics(SM_CXSIZE), 0 FillRect lDc, tr, hBrush If bGradientFill Then ConvertLongToRGB MyColor, r, g, b With vert(0) .x = 0 .y = 0 .Red = TransfCol(r) .Green = TransfCol(g) .Blue = TransfCol(b) .Alpha = TransfCol(0) End With With vert(1) .x = tr2.Right .y = tr2.Bottom .Red = TransfCol(0) .Green = TransfCol(0) .Blue = TransfCol(0) .Alpha = TransfCol(0) End With tPt.UpperLeft = 0 tPt.LowerRight = 1 GradientFillRect lDc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H End If Call DeleteObject(hBrush) SetRect tr2, tr2.Right - GetSystemMetrics(SM_CXSIZE), 0, _ tr2.Right, GetSystemMetrics(SM_CYSIZE) OffsetRect tr2, -4, 2 DrawFrameControl lDc, tr2, DFC_CAPTION, DFCS_CAPTIONCLOSE ReleaseDC lhwnd, lDc Call EndPaint(lhwnd, tPS) End Sub Private Sub GetHiLoword _ (lParam As Long, ByRef loword As Long, ByRef hiword As Long) loword = lParam And &HFFFF& hiword = lParam \ &H10000 And &HFFFF& End Sub 2- كود في Standard Module اخر : Option Explicit Private Type FontAttributes FONT_NAME As String FONT_SIZE As Long FONT_BOLD As Boolean FONT_ITALIC As Boolean FONT_UNDERLINE As Boolean End Type Sub test() Dim tFontAttr As FontAttributes Dim aCharColors() As Variant Dim lTitleBarColor As Long 'define a random title bar color lTitleBarColor = RGB(0, 255, 0) 'build the caption font structure With tFontAttr .FONT_NAME = "Arial" '"Trebuchet MS" .FONT_SIZE = 8 .FONT_BOLD = True .FONT_ITALIC = False .FONT_UNDERLINE = False End With 'build the caption individual character colors ReDim aCharColors(Len(UserForm1.Caption)) '===> (=16 chars in this case) aCharColors(0) = vbRed 'U aCharColors(1) = vbRed 's aCharColors(2) = vbRed 'e aCharColors(3) = vbRed 'r aCharColors(4) = vbBlue 'F aCharColors(5) = vbBlue 'o aCharColors(6) = vbBlue 'r aCharColors(7) = vbBlue 'm aCharColors(8) = vbYellow '1 aCharColors(9) = 0 aCharColors(10) = vbRed '- aCharColors(11) = 0 aCharColors(10) = vbWhite 'D aCharColors(12) = vbWhite 'e aCharColors(13) = vbWhite 'm aCharColors(14) = vbWhite '0 aCharColors(15) = vbWhite '0 'display the userform Call ShowFormatedUserForm( _ Form:=UserForm1, _ TitleBarColor:=lTitleBarColor, _ GradientFill:=True, _ FontAttributesPtr:=VarPtr(tFontAttr), _ CharColorsPtr:=VarPtr(aCharColors(0)) _ ) End Sub

كود لجعل الفورم شفاف مع الابقاء على شريط عنوان الفورم و اطاره و على جميع الكونترولات بداخله ملف للتحميل : https://app.box.com/s/pzaml5g8slh8kq7bd03axq01vzmrldai الكود في موديول الفورم: Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Const LWA_COLORKEY = &H1 Private Const GWL_EXSTYLE = (-20) ' Private Const WS_EX_LAYERED = &H80000 Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindow(vbNullString, Me.Caption) SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED Me.BackColor = vbRed SetLayeredWindowAttributes hwnd, vbRed, 0&, LWA_COLORKEY End Sub

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

50 مشاركة ... 67 إعجاب .. يعني إعجاباتك تجاوزت عدد مشاركاتك وهذ متوقع من أعمالك التي حرمنا منها طويلاً الحمد لله أن رزقنا الله بك أخي الحبيب جعفر تقبل تحياتي

شكرا يا أستاد محمد حسن الكود يشتغل جيدا على أجهزة 32Bit .. و لكي يشتغل على 64Bit يتطلب تعديلا على ال API declarations تعديل ال Windows API declarations ليس أمرا صعبا لكنه يتطلب امتلاك جهاز من 64Bit لتجريب الكود ... للأسف ليس لدي جهاز 64Bit لكي أعدل و أجرب الكود .. ان شاء الله قريبا سأبدل الجهاز

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

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

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

استاذى وابى الفاضل واسمح لى ان اكون مثل ابنك والله انك لمبدع كل ما اود قوله ان يزيدك الله من فضله وكرمه (والله هذا الدعاء نطق به لسانى دون تفكير مجرد رأيتى للعمل) تقبل تحياتى

ليس ضروريا أن يتم الاشارة الى الفرييم داخل الكود ... لو السطر التالي لا ينتج عنه خطأ ابتداء من الدورة الثانية في ال Do .. Loop : Set oRealActiveControl = oTempObj.ActiveControl يعني أننا بصدد Frame Control

السلام عليكم و رحمة الله و بركاته بارك الله فيك على هذه الاضافة .. جزاك الله خيرًا و زادها بميزان حسناتك تحياتي

في حالة وضع التيكست بوبكس داخل فريم يمكن استعمال الكود التالي : ملف للتحميل : https://app.box.com/s/5ttc2dafv4sj3e1g03r95ppd57ftqqmg Private Sub Label1_Click() Dim oTempObj As Object Dim oRealActiveControl As Object On Error Resume Next Set oTempObj = Me Do Set oRealActiveControl = oTempObj.ActiveControl If Err <> 0 Then Exit Do Set oTempObj = oRealActiveControl DoEvents Loop On Error GoTo 0 If TypeName(oRealActiveControl) = "TextBox" Then If Len(oRealActiveControl) = 0 Then oRealActiveControl = Date Else MsgBox "Date already entered in TextBox : '" & oRealActiveControl.Name & "'" End If Else MsgBox "You need to select a TextBox first" End If End Sub

بارك الله فيك أيها المتمكن خالد صراحة يعجبني أسلوبك في المعادلات بشكل رهيب وخصوصاً الدالة INDIRECT ..كأنها سحر المعادلات

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

السلام عليكم ورحمة الله وبركاتة كلنا نعرف دالة الاكسيل المشهورة ( VLOOKUP ) التى تبحث فى العمود الاول فقط من جدول وتستخرج النتيجة من عمود اخر دالتنا اليوم واسمها ( VLOOKAnyCol ) هى مثل دالة الاكسيل المشهورة ( VLOOKUP ) تماما وتمتاز عنها بعدم اشتراط البحث فى العمود الاول فقط فهى تبحث فى اى عمود ولا يشترط ان يكون العمود الاول وتستخرج النتيجة من عمود اخر - ولا تشترط ترتيب جدول البيانات وهى طبعا عربية بأيدى عربية شرح وبناء دالة ( VLOOKAnyCol ) :: دالة VLOOKAnyCol لها اربع مدخلات او باراميترات هم على التوالى :: جدول_البيانات / قيمة_البحث / عمود_البحث / عمود_النتيجة المدخل الأول :: جدول_البيانات :: جدول المعلومات الذي يتم البحث فيه عن البيانات ( قيمة_البحث ) فى اى عمود منه استخدم أحد المراجع لأحد النطاقات أو أحد أسماء النطاقات، مثل MyRng المدخل الثانى :: قيمة_البحث :: القيمة التي سيتم البحث عنها في العمود الذى تحدده ب ( عمود_البحث ) من جدول_البيانات يمكن أن تكون قيمة_البحث قيمة أو مرجع أو سلسلة نصية المدخل الثالث :: عمود_البحث :: هو رقم عمود الجدول الذى سيتم البحث فيه عن قيمة_البحث من جدول_البيانات المدخل الرابع :: عمود_النتيجة :: هو رقم عمود الجدول الذى سيتم استخراج النتيجة منه المقابلة ل قيمة_البحث والى لقاء قريب بإذن الله فى سلسلة الدوال العربية بالمرفقات الشرح مع مثال : VLOOKAnyCol.rar المرفق التالى عبارة عن ملف قيديو يبين كيفية نقل كود الدالة الى ملقك لتعمل الدالة به Omar_1.rar

برنامج_مخازن_جديد.xlsm

اخواني الكرام اضع بين ايديكم الجزء الاول من شرح الترحيل وبإنتظار تعليقاتكم واستفسارتكم ابواحمد الجزء الاول من الشرح ملف شرح الجزء الاول الترحيل.rar الجزء الثاني من الشرح ملف شرح الجزء الثانى الترحيل2.rar الجزء الثالث من الشرح (ترحيل القيم - ترحيل محدوود) ملف شرح الجزء الثالث الترحيل3.rar الجزء الرابع من شروحات الترحيل ملف شرح الجزء الرابع ترحيل حسب اسم الشيت.rar لا تنسوني أخوتي من الدعاء لي بظهر الغيب

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أقدم لكم كود متميز جداً .. كود في منتهى الروعة .. إن شاء الله تستفيدوا منه أقصى استفادة .. الكثير منا يبحث عن موضوع فصل الناجحين والراسبين .. ها أنا أقدم لك على طبق من كود : الكود الذهبي الذي سيقوم بذلك بمنتهى السهولة واليسر .. هذا هو الشكل العام للكود Sub SplitFilteredData() 'الإعلان عن المتغيرات Dim MySheet As Worksheet Dim MyRange As Range Dim UList As Collection Dim UListValue As Variant Dim I As Long 'تخصيص ورقة العمل النشطة Set MySheet = ActiveSheet 'إذا لم تحتوي ورقة العمل على فلترة يتم الخروج من الإجراء الفرعي If MySheet.AutoFilterMode = False Then Exit Sub End If 'حدد العمود الذي يحتوي على البيانات المراد عمل تصفية لها Set MyRange = Range(MySheet.AutoFilter.Range.Columns(5).Address) 'إنشاء كائن تجميعي Set UList = New Collection 'وضع قيم في الكائن التجميعي بالقيم الفريدة أي الغير مكررة فقط On Error Resume Next For I = 2 To MyRange.Rows.Count UList.Add MyRange.Cells(I, 1), CStr(MyRange.Cells(I, 1)) Next I On Error GoTo 0 'حلقة تكرارية للقيم الموجودة داخل الكائن التجميعي For Each UListValue In UList 'حذف أية أوراق عمل تم إنشاءها من قبل On Error Resume Next Application.DisplayAlerts = False Sheets(CStr(UListValue)).Delete Application.DisplayAlerts = True On Error GoTo 0 'عمل تصفية لمطابقة القيمة الحالية MyRange.AutoFilter Field:=5, Criteria1:=UListValue 'نسخ النطاق الذي تم تصفيته إلى ورقة عمل جديدة MySheet.AutoFilter.Range.Copy Worksheets.Add.Paste ActiveSheet.Name = Left(UListValue, 30) Cells.EntireColumn.AutoFit 'إعادة الحلقة التكرارية مع قيمة أخرى Next UListValue 'الذهاب للصفحة التي تحتوي على البيانات وإزالة الفلترة MySheet.AutoFilter.ShowAllData MySheet.Select End Sub في الفيديو شرح لكيفية استخدام الكود .. ومرفق في الموضوع الملف الذي تم الشرح عليه إليكم رابط الفيديو لا تنسونا من صالح دعائكم ، ولا تنسوا اللايكات في اليوتيوب ... تقبلوا تحيات أخوكم أبو البراء Split Filtered Data VBA.rar Split Filtered Data VBA V2.rar

الأستاذ القدير / محمد حسن محمد فكرة أكثر من ارائعة من أستاذ فاضل أفكارك بالفعل جميلة ومفيدة جدا جدا سر على بركة الله

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

أخى الحبيب الفاضل أ / جعفر الطريبق بالفعل عمل أكثر من رائع جزاك الله به خيرا

اخي حسين كودك الذي عرضته بالمشاركة الاولى يحقق طلبك If Dir("C:\WINDOWS\MOVI.txt") = "" Then MsgBox "يعمل" Else MsgBox "لا تعمل" End If ايضا الكود الثاني والذي عرضه الاستاذ محمد If Len(Dir("C:\WINDOWS\MOVI.txt")) > 0 Then MsgBox "لا يعمل" Else MsgBox "اعمل" End If

شكرا اخي الفاضل ابو خليل علي مرورك الطيب لوسمحت اخي الفاضل ابو خليل التعديل علي الكود ليتناسب مع اذا كان الملف غير موجود إذا فيكون الجواب الاول = تشغيل ، وإلا = اغلاق

اللهمّ أبدله داراً خيراً من داره، وأهلاً خيراً من أهله، وأدخله الجنّة، وأعذه من عذاب القبر ومن عذاب النّار اللهمّ عامله بما أنت أهله، ولا تعامله بما هو أهله اللهمّ اجزه عن الإحسان إحساناً وعن الإساءة عفواً وغفراناً اللهمّ إن كان محسناً فزد من حسناته، وإن كان مسيئاً فتجاوز عن سيّئاته اللهمّ أدخله الجنّة من غير مناقشة حساب ولا سابقة عذاب اللهمّ اّنسه في وحدته وفي وحشته وفي غربته اللهمّ أنزله منزلاً مباركاً وأنت خير المنزلين اللهمّ أنزله منازل الصدّيقين والشّهداء والصّالحين، وحسن أولئك رفيقاً اللهمّ اجعل قبره روضةً من رياض الجنّة، ولا تجعله حفرةً من حفر النّار اللهمّ افسح له في قبره مدّ بصره، وافرش قبره من فراش الجنّة اللهمّ أعذه من عذاب القبر، وجفاف ِالأرض عن جنبيها اللهمّ املأ قبره بالرّضا والنّور والفسحة والسّرور اللهمّ إنّه في ذمّتك وحبل جوارك، فقِهِِ فتنة القبر، وعذاب النّار، وأنت أهل الوفاء والحقّ، فاغفر له وارحمه إنّك أنت الغفور الرّحيم اللهمّ إنّه عبدك وابن عبدك خرج من الدّنيا وسعتها ومحبوبها وأحبّائه فيها إلى ظلمة القبر وما هو لاقيه اللهمّ إنّه كان يشهد أنّك لا إله إلّا أنت وأنّ محمّداً عبدك ورسولك وأنت أعلم به اللهمّ إنّا نتوسّل بك إليك، ونقسم بك عليك أن ترحمه ولا تعذّبه، وأن تثبّته عند السؤال اللهمّ إنّه نَزَل بك وأنت خير منزولٍ به، وأصبح فقيراً إلى رحمتك وأنت غنيٌّ عن عذابه اللهمّ آته برحمتك ورضاك، وقهِ فتنة القبر وعذابه، وآته برحمتك الأمن من عذابك حتّى تبعثه إلى جنّتك يا أرحم الرّاحمين اللهمّ انقله من مواطن الدّود وضيق اللحود إلى جنّات الخلود اللهمّ احمه تحت الأرض، واستره يوم العرض، ولا تخزه يوم يبعثون "يوم لا ينفع مالٌ ولا بنون إلّا من أتى الله بقلبٍ سليم" اللهمّ يمّن كتابه، ويسّر حسابه، وثقّل بالحسنات ميزانه، وثبّت على الصّراط أقدامه، وأسكنه في أعلى الجنّات بجوار حبيبك ومصطفاك (صلّى الله عليه وسلّم) اللهمّ أمّنه من فزع يوم القيامة، ومن هول يوم القيامة، واجعل نفسه آمنة مطمئنّة، ولقّنه حجّته اللهمّ اجعله في بطن القبر مطمئنّاً وعند قيام الإشهاد آمن، وبجود رضوانك واثق، وإلى أعلى درجاتك سابق اللهم اجعل عن يمينه نوراً حتّى تبعثه آمناً مطمئنّاً في نورٍ من نورك اللهمّ انظر إليه نظرة رضا، فإنّ من تنظر إليه نظرة رضا لا تعذّبه أبداً اللهمّ أسكنه فسيح الجنان، واغفر له يا رحمن، وارحمه يا رحيم، وتجاوز عمّا تعلم يا عليم، اللهمّ اعف عنه فإنّك القائل "ويعفو عن كثير" اللهمّ إنّه جاء ببابك، وأناخ بجنابك، فَجد عليه بعفوك وإكرامك وجود إحسانك اللهمّ إنّ رحمتك وسعت كلّ شيء فارحمه رحمةً تطمئنّ بها نفسه، وتقرّ بها عينه اللهمّ احشره مع المتّقين إلى الرّحمن وفداً اللهمّ احشره مع أصحاب اليمين، واجعل تحيّته سلامٌ لك من أصحاب اليمين اللهمّ بشّره بقولك "كلوا واشربوا هنيئاً بما أسلفتم في الأيّام الخالية" اللهمّ اجعله من الّذين سعدوا في الجنّة خالدين فيها ما دامت السموات والأرض اللهمّ لا نزكّيه عليك، ولكنّا نحسبه أنّه أمن وعمل صالحاً، فاجعل له جنّتين ذواتي أفنان بحقّ قولك: "ولمن خاف مقام ربّه جنّتان" اللهمّ شفع فيه نبيّنا ومصطفاك، واحشره تحت لوائه، واسقه من يده الشّريفة شربةً هنيئةً لا يظمأ بعدها أبداً اللهمّ اجعله في جنّة الخلد (الّتي وُعد المتقون كانت جزاءً ومصيراُ لهم ما يشاؤون وكان على ربّك وعداُ ومسؤولاً) اللهمّ إنّه صبر على البلاء فلم يجزع، فامنحه درجة الصّابرين الّذين يوفون أجورهم بغير حساب فإنّك القائل " إنّما يوفي الصّابرون أجرهم بغير حساب " اللهمّ إنّه كان مصلّ لك، فثبّته على الصّراط يوم تزل الأقدام اللهمّ إنّه كان صائماً لك، فأدخله الجنّة

تستطيع بالكود نفسه تحقيق الشرط الكود يقول : اذا كان الملف غير موجود إذا فيكون الجواب الاول = تشغيل ، وإلا = اغلاق اما ان كنت تريد من الكود عكس هذا فيمكن تعديله على هذا النحو If Len(Dir("C:\WINDOWS\MOVI.txt") )>0 Then الكود يقول : اذا كان عدد حروف الملف اكبر من صفر ( يعني موجود) إذا فيكون الجواب الاول = اغلاق ، وإلا = تشغيل ما شاء الله اخوي حسين فكرة بديعة لم تخطر على البال من قبل

يتكرر بسب عدم وجود مفتاح اساسي منفرد ويبدو ان لديك تكرار حقيقي في رقم الفاتورة انظر التعديل الآن : يستحيل التكرار سيتم عرض سجل واحد فقط بمعلومية حقلي رقم الفاتورة والشراء يوجد عندي مشكلة في رفع الملفات الحل هو ان تجعل حقل الشراء معيار ايضا مع رقم الفاتورة في التقرير ليصبح داخل التقرير معيارين

يا غالى دخلت على الرابط لا يفتح حاول ارفعه على سرفر المنتدى تقبل تحياتى

السلام عليكم و رحمة الله و بركاته جزاك الله خيرًا أستاذنا الفاضل جعفر الطريبق

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

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

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

انا لله وانا اليه راجعون . اللهم تقبل كل اعماله واجعلها صدقة جاريه اسال الله ان يسكنه الفردوس الاعلى

السلام عليكم اسمحوا لي بالمشاركة معكم هذا الكود كامل بالمطلوب ويمكنكم تسمية النسخة واللاحقة بما تريدون يتم اخذ النسخة عند اغلاق النموذج / انظر المرفق Dim DBOld As String Dim DBNew As String Private Sub Form_Load() DBOld = CurrentProject.Path & "\Data.mdb" 'اختيار قاعدة بيانات الجداول DBNew = CurrentProject.Path & "\Backup" 'اختيار مكان حفظ النسخة End Sub Private Sub Form_Close() On Error Resume Next Shell "cmd.exe /C copy " & """" & DBOld & """" & " " & """" & DBNew & "\" & "Data.mdb" & """", 0 End Sub xxxx.rar

جزاك الله خير أخي العزيز الأستاذ / عماد مزيد من المعلومات المفيدة بارك الله فيكم جعل الله قدومك خير في هذا المنتدى تقبل تحياتي وتقديري

طريقة سريعة وسهلة بارك الله فيك

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

السلام عليكم ورحمة الله اخي أبو يحى بارك الله فيك, الصفر من ضمن شروط المعادلة IF(C4>D4;C4;0)= الشرط يقول في حالة False ان تضع صفـــــر وهنا لديك إختيارات كثيره اما صفر او فراغ بتبديل الصفر بعلامتي تنصيص او أي نص تريده بوضعه بين علامتي التنصيص او حسب ما أشتار إليك الأستاذ مختار ليس أمامك الا Numeric format الذى فى كود الأستاذ جعفر جزاهم الله عنا خير الجزاء

اللهم اغفر له اللهم ارحمه

السلام عليكم و رحمة الله و بركاته أخي الغالي الخليفة الأول أستاذي الفاضل الشهابي لا تظن عزيزي الخليفة أنّي نسيت الموضوع .. قمت بهذه المحاولة ربما تقرّب الفكرة لديك .. كملاحظة قمت بالاشتغال على ثلاث صفحات فقط ريثما ترى أنت الفكرة ..فإن أعجبتك سنواصل الملف .. و إذا لم تنلْ إعجابك فقد استفدت منها أنا في نهاية المطاف لا تهتم بالأرقام في الصفحات و النطاقات المُدخلة فهي تجريبية .. أتمنى من أستاذنا الشهابي أن يمدّنا برأيه السّديد آسف على الرابط الخارجي فالحجم أكبر من المسموح به خالص احتراماتي http://www.gulfup.com/?pOqqOi

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

السلام عليكم استاذتى واخوتى الاحباء فى منتديات اوفيسنا اقدم لكم عمل من اعمالى المتواضعة (برنامج كنترول المرحلة الابتدائية للصفوف الاول والثانى والثالث الابتدائي للعام الدراسي 2015 / 2016) واتمنى من الله ان ينال رضاكم اليكم روابط تحميل البرنامج ومرفق مع البرنامج ملف وورد به تعليمات العمل بالبرنامج قم باتباع التعليمات جيدا حتى لا تحدث اى اخطاء تحياتى للجميع بعام دراسي سعيد قنديل الصياد رابط مركز الخليج http://www.mrkzgulf.com/do.php?id=42357 رابط على مركز واتا http://www.wata.cc/up/view.php?file=51c669abd5 رابط على مركز مخزن http://www.m5zn.com/d/?15980438 رابط على مركز عرب شير http://arabsh.com/files/0b37434e6cf2/برنامج-كنترول-المرحلة-الابتدائية_2016-rar.html رابط على مركز العرب http://3rbup.com/8a6f8a5bb1078122

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

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

اخى واستاذى الحبيب ابو البراء كلام حضرتك شرف كبير لى .... جزاك الله خيراً خالص حبى وتقديرى لشخصكم الكريم

هلا والله

حالة عملية رقم (2) بافتراض ان لديك البيانات التالية: عن المبيعات الفعلية والمتوقعة وتحتاج الى عمل تحليل ماذا-لو تغير معدل النمو في المبيعات المتوقعة لعام 2016 الى 0% او -2% او 1% او 2%.... الخ . فماذا سيؤثر ذلك على رقم المبيعات. خطوات الحل : قم بأعداد جدول البيانات بهذا الشكل وادخل الاحتمالات في معدل النمو بشكل يدوى في خلية ادخال العمود من (B11:B15 ), ثم ادخل صيغه في خلية ادخال الصف C10 . حدد النطاق من B10:C15 . افتح علامة التبويب بيانات ثم جدول بيانات. حدد خلية ادخال العمود وهي C3 افتراض النمو . اضغط موافق واستمتع بمشاهدة النتائج في النطاق C11:C15. ويمكنك ادراج رسم بياني بهذا الشكل . 1-2.rar

الأمثلة العملية حالة عملية رقم (1) بافتراض انك ترغب فى شراء شقة سكنية او سيارة بالتقسيط ثم جاءك عروض بأكثر من سعر او اكثر من سعر فأئده ....الخ وتوافرت لديك هذه المعطيات ولديك عدة تساؤلا بخصوص الفائدة فماذا لو تغير سعر الفائدة من 5% الى 6% او 7% ..... الخ ؟ وماذا سيكون تأثيره على مبلغ القرض او الدفعة الشهرية او أجمالي الفوائد .....الخ ؟ يمكن الإجابة على هذه التساؤلات باستخدام جدول بيانات ذات متغير واحد . يوجد ملف اكسيل بالمثال خطوات عمل جدول البيانات ذات المتغير الواحد قم بعمل خلايا الادخال وخلايا النتائج كما في الشكل السابق. قم بعمل خلية الادخال اليدوي في العمود وهو معدل الفائدة عند مستويات تحددها انت في النطاق من (.(F6:F14 انشاء مرجع للخلية في الصف حدد الخلايا او النطاق التي تحتوي على الصيغة والادخال اليدوي من F5:J14. اذهب الى علامة التبويب بيانات ثم جدول بيانات . حدد الخلية C8 في خلية ادخال العمود . اضغط موافق . شاهد نتائج تحليل ماذا لو في تقرير واحد . ملاحظة: تم انشاء النتائج في الجدول من مجموعة صيغ متعددة نتج عنها معادلة صفيف وهى معادلة لا يمكن التعديل عليها وستظهر لك رسالة الخطأ هذه (نتائج المعادلة) {=TABLE(;C8)} في هذا المثال كانت خلايا الادخال في العمود وخلايا الصيغ في الصف لذا ادخال مرجع الخلية في خلية ادخال العمود إذا اردت ان تعكس مكان خلايا الادخال في الصف وستكون الصيغ في العمود لذا سيتم ادخال مرجع الخلية في خلية ادخال الصف. المشاركة التاليه الحاله العملية رقم (2) 1-1.rar

بسم الله الرحمن الرحيم أخى عادل بالملف المرفق الحل بطريقه اخرى السلام عليكم rename_and_color2_01.rar

السلام عليكم اخي العزيز ان ماتطلبه بالفعل موجود بالملف الزر الاول تم عمله لانه يمكن اسعماله في اي موقف ليكون به المرونه لعمل اي اضافه داخل الملف و لعمل ما تريده انت الان اضف بالزر الاول عدد الصفحات التي تريد و هي 356 في طلبك وعند اضافتها ستجدها مسلسله اليس كذلك تمام الان اضغط الزر الثاني و هو تغير الاسماء و اعلمني بالنتيجه مرفق الملف مرة ثانيه لاني وجدت رسالة خطا تم تعديله تحياتي rename_and_color3.rar