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

نعم قمت بتصميمه على قواعد سيكوال على قاعدة البيانات الخاصة بالاستضافة

السلام عليكم من المعروف أن الاكسل يسمح باضافة صورة خلفية لورقة العمل عن طريق Page Layout ==> BackGround لكن ليس من الممكن اضافة صورة خلفية فقط لجزء من الورقة يعني صورة وراء بعض الخلايا فقط .. الكود التالي يسمح لنا بذالك http:// الكود في موديول عادي Option Explicit Private Type POINTAPI x As Long y As Long End Type Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr #Else Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr #End If #Else 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long #End If #If VBA7 Then Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hwnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private lRgn1 As LongPtr, lRgn2 As LongPtr Private hwndImage As LongPtr, hwndExcel7 As LongPtr #Else Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long Private Declare Function GetDC 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 MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd 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 lRgn1 As Long, lRgn2 As Long Private hwndImage As Long, hwndExcel7 As Long #End If Private Const GWL_STYLE = (-16) Private Const WS_CAPTION = &HC00000 Private Const WS_BORDER = &H800000 Private Const WS_DLGFRAME = &H400000 Private Const WS_THICKFRAME = &H40000 Private Const WS_DISABLED = &H8000000 Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_LAYERED = &H80000 Private Const WS_EX_TRANSPARENT = &H20& Private Const WS_EX_DLGMODALFRAME = &H1 Private Const WS_EX_TOPMOST = &H8& Private Const LOGPIXELSX = 88 Private Const LOGPIXELSY = 90 Private Const POINTSPERINCH = 72 Private Const SWP_FRAMECHANGED = &H20 Private Const RGN_AND = 1 Private Const LWA_ALPHA = &H2& Private tTargetRangeRect As RECT Private oTargetRange As Range 'Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long ' Calling Macros .. '-------------------------- Public Sub ShowImage() Call DisplayImage(UserForm1, Sheet1.Range("B8: E20")) End Sub Public Sub HideImage() Call CleanUp(UserForm1) End Sub 'Public Routines .. '------------------- Public Sub DisplayImage(ByVal Img As Object, ByVal TargetRange As Range) KillTimer Application.hwnd, 0 RemoveProp Application.hwnd, "Image" If GetProp(Application.hwnd, "Image") <> 0 Then Exit Sub Set oTargetRange = TargetRange hwndExcel7 = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", vbNullString) tTargetRangeRect = GetRangeRect(oTargetRange) Img.StartUpPosition = 0 hwndImage = FindWindow(vbNullString, Img.Caption) SetProp Application.hwnd, "Image", hwndImage Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) And Not WS_CAPTION) DrawMenuBar hwndImage Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) _ And Not WS_BORDER And Not WS_THICKFRAME And Not WS_DLGFRAME Or WS_DISABLED) With tTargetRangeRect Call SetWindowPos(hwndImage, WS_EX_TOPMOST, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_FRAMECHANGED) End With Call SetWindowLong(hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME) SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_LAYERED SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_TRANSPARENT SetLayeredWindowAttributes hwndImage, 0, 128, LWA_ALPHA Img.Show vbModeless SetTimer Application.hwnd, 0, 1, AddressOf ImagePositionMonitor End Sub Public Sub CleanUp(ByVal Img As Object) KillTimer Application.hwnd, 0 RemoveProp Application.hwnd, "Image" Unload Img End Sub 'Private Routines .. '------------------- Private Sub ImagePositionMonitor() Static l1 As Long, t1 As Long, r1 As Long, b1 As Long, _ l2 As Long, t2 As Long, r2 As Long, b2 As Long Dim tpt1 As POINTAPI, tpt2 As POINTAPI, tCurPos As POINTAPI Dim tVsbRngRect As RECT On Error Resume Next tVsbRngRect = GetRangeRect(ActiveWindow.VisibleRange) tTargetRangeRect = GetRangeRect(oTargetRange) GetCursorPos tCurPos ' If GetAsyncKeyState(vbKeyLButton) <> 0 And PtInRect(tVsbRngRect, tCurPos) <> 0 And _ ' TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _ ' tTargetRangeRect.Left = l1 Then Exit Sub If GetAsyncKeyState(vbKeyLButton) <> 0 And _ TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _ tTargetRangeRect.Left = l1 Then Exit Sub If Not ActiveSheet Is oTargetRange.Parent Or IsIconic(Application.hwnd) Then ShowWindow hwndImage, 0 Exit Sub Else ShowWindow hwndImage, 1 End If With tTargetRangeRect MoveWindow hwndImage, .Left, .Top, _ .Right - .Left, _ .Bottom - .Top, True tpt1.x = .Left tpt1.y = .Top tpt2.x = .Right tpt2.y = .Bottom ScreenToClient hwndExcel7, tpt1 ScreenToClient hwndExcel7, tpt2 .Left = tpt1.x .Top = tpt1.y .Right = tpt2.x .Bottom = tpt2.y End With With tVsbRngRect tpt1.x = .Left tpt1.y = .Top tpt2.x = .Right tpt2.y = .Bottom ScreenToClient hwndExcel7, tpt1 ScreenToClient hwndExcel7, tpt2 .Left = tpt1.x .Top = tpt1.y .Right = tpt2.x .Bottom = tpt2.y End With With tTargetRangeRect If .Left <> l1 Or .Top <> t1 Or tVsbRngRect.Left <> l2 Or tVsbRngRect.Top <> t2 Or _ .Right <> r1 Or .Bottom <> b1 Or tVsbRngRect.Right <> r2 Or tVsbRngRect.Bottom <> b2 Then lRgn1 = CreateRectRgn(-tVsbRngRect.Left, -tVsbRngRect.Top, tVsbRngRect.Right, tVsbRngRect.Bottom) lRgn2 = CreateRectRgn(tVsbRngRect.Left - .Left, tVsbRngRect.Top - .Top, _ tVsbRngRect.Right - .Left, tVsbRngRect.Bottom - .Top) Call CombineRgn(lRgn2, lRgn2, lRgn1, RGN_AND) SetWindowRgn hwndImage, lRgn2, True DeleteObject lRgn1 DeleteObject lRgn2 End If End With With tTargetRangeRect l1 = .Left t1 = .Top r1 = .Right b1 = .Bottom End With With tVsbRngRect l2 = .Left t2 = .Top r2 = .Right b2 = .Bottom End With End Sub Private Function GetRangeRect(ByVal rng As Range) As RECT Dim OWnd As Window Set OWnd = rng.Parent.Parent.Windows(1) With rng GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _ + OWnd.PointsToScreenPixelsX(0) GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _ + OWnd.PointsToScreenPixelsY(0) GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _ + GetRangeRect.Left GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _ + GetRangeRect.Top End With End Function Private Function PTtoPX _ (Points As Single, bVert As Boolean) As Long PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH End Function Private Function ScreenDPI(bVert As Boolean) As Long Static lDPI(1), lDC If lDPI(0) = 0 Then lDC = GetDC(0) lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX) lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY) lDC = ReleaseDC(0, lDC) End If ScreenDPI = lDPI(Abs(bVert)) End Function بم تجريب الكود على Windows 64Bit Office 2010 64Bit و Windows 7 32Bit Office 2007 ملف للتحميل

الاخ الالفى لا ادرى ان كنت تعلم قواعد المنتدى ام لا على العموم انشىء موضوع جديد حتى يتسنى لجميع الاعضاء رؤيه ملفك ومحاوله مساعدتك

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

سؤال يطرح نفسه وبقوة ولكن ما الحيلة فلايمكن التغيير فى قواعد بيانات accde ولكن متاحة بالنسبة للجداول والاستعلامات ويمكن ان نستغل ذلك لصالحنا ان يكون التحديث على هيئة قاعدة بيانات كاملة accde ويمكن استيراد الجداول والاستعلامات من القاعدة القديمة برمجيا

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

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود ترحيل الصفحة كامله بشرط واحد على سبيل المثال عندنا درجات الطلاب وفيهم طلاب ناجحون وطلاب دور ثان وطلاب راسبون هذا الكود يفصل الطلاب الناجحون في ورقة ويفصل الطلاب الذين لهم حق الدخول في الدور الثاني في صفحة أخرى ويفصل الطلاب الراسبون في صفحة أخرى وهكذا طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر Sub KH_START()[/center] ''' متغيرات بعدد الصفحات المطلوب الترحيل اليها Dim R As Integer, M As Integer, N As Integer, O As Integer ''' أسماء الصفحات المطلوب الترحيل اليها والمدى المطلوب مسح البيانات الثديمة منه Sheets("ناجح").Range("A11:DZ1000").ClearContents Sheets("دور ثان في").Range("A11:DZ1000").ClearContents Sheets("رسوب").Range("A11:DZ1000").ClearContents ''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات M = 11: N = 11: O = 12 Application.ScreenUpdating = False ''' بداية ونهاية صفوف الورقة المصدر For R = 11 To 1000 ''''''''''''''''''''''''''''''''''''''''''''''''''''' ''' رقم عمود المعيار وكلمة المعيار If Cells(R, 113) = "ناجح" Then Range("A" & R).Resize(1, 115).Copy ''' سيتم اللصق في هذا الشيت Sheets("ناجح").Range("A" & M).PasteSpecial xlPasteValues Application.CutCopyMode = False M = M + 1 '''''''''''''''''''''''''''''''''''''''''''''''''''' ''' رقم عمود المعيار وكلمة المعيار ElseIf Cells(R, 113) = "دور ثان في" Then Range("A" & R).Resize(1, 115).Copy ''' سيتم اللصق في هذا الشيت Sheets("دور ثان في").Range("A" & N).PasteSpecial xlPasteValues Application.CutCopyMode = False ''' اجعل الرقم 1 الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل N = N + 1 ''''''''''''''''''''''''''''''''''''''''''''''''''''' ElseIf Cells(R, 113) = "رسوب" Then Range("A" & R).Resize(1, 115).Copy Sheets("رسوب").Range("A" & O).PasteSpecial xlPasteValues Application.CutCopyMode = False ''' لترك صف فارغ اعلا كل صف O = O + 2 End If ''''''''''''''''''''''''''''''''''''''''''''''''''''' Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' وإذا اردت زيادة عدد الصفحات الطلوب نقل وترحيل البيانات اليها ... سهلة إن شاء الله ماعليك إلا أن تضيف هذه الجزئيه في الكود مع كتابة اسم الصفحة الجديده والمعيار الجديد ''' رقم عمود المعيار وكلمة المعيار ElseIf Cells(R, 113) = "دور ثان في" Then Range("A" & R).Resize(1, 115).Copy ''' سيتم اللصق في هذا الشيت Sheets("دور ثان في").Range("A" & N).PasteSpecial xlPasteValues Application.CutCopyMode = False ''' اجعل الرقم 1 الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل N = N + 1 ودمتم في حفظ الله ترحيل مفيد جدا كل الصفحة بشرط.rar

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والاذكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود التنقل الى اي صفحة في ملف اكسيل طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ' ' هذا الكود للعالم العلامة عبد الله باقسير Sub GO_TO() On Error Resume Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If Activewindow.ScrollColumn = 1 Activewindow.ScrollRow = 1 On Error GoTo 0 End Sub في هذا الكود البسيط والمفيد عند الضغط على الزر ستنسدل قائمة بأسماء كل الصفحات الموجوده بالملف اختر منها الورقة التي تبعاها ودمتم في حفظ الله التنقل بين الصفحات.rar

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود طباعة بعد المعاينة في هذا الكود البسيط والمفيد سيتم الطباعة بعد ظهور رساله تسألك هل تود الطباعة بعد المعاينة فإذا كانت المعاينة تناسبك قل نعم وان لم تكن تناسبك وتريد التضبيط فقل لا طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ' هذا الكود للمهندس علي السحيب Sub معاينة_مع_الطباعة() ActiveWindow.SelectedSheets.PrintPreview A = MsgBox("هل تود الطباعة بعد المعاينة؟", vbYesNo + vbQuestion, "طباعة") If A = vbYes Then With ActiveSheet .PrintOut End With End If Range("A1").Activate End Sub ودمتم في حفظ الله معاينة طباعة مع امكانية الطباعه.rar

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

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود تفقيط ولاأروع يصلح لتحويل ارقام المجموع الكلي للطلاب الى تفقيط ويصلح ايضا لرجال الماهيات طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر '-- Abo Hadi, 28/07/2003 --' '-- Last update on 28/07/2006 ' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت 'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب ' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط 'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح Option Explicit Public Const vArabic As Byte = 1 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null) myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue) End Function Private Function Delete(S As String, Index As Integer, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Private Function Insert(Source, S As String, Index As Integer) As String Dim LPart As String Dim RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Private Function AddAnd(S1 As String, S2 As String, S3 As String, _ And_ As String, Lang As Byte) As String Dim InAnd_ As String Dim CollectS As String If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " " If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = "" CollectS = S1 + And_ + S2 If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = "" AddAnd = CollectS + And_ + S3 End Function Private Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1 As String Dim Sngl_2 As String K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تانِ" Else Sngl_2 = Sngl_2 & "انِ" End If End If If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1)) Select Case LLeter Case 201 ' "ة" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تانِِ" Case 236 ' "ى" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يانِ" Case 199 ' "ا" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Case 193 ' "ء" If Right(Sngl_1, 2) = "اء" Then If Sex = 1 Then Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Else Sngl_1 = Sngl_1 & "انِ" End If End If Case Else If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "انِ" End Select If Sngl_2 <> "" Then S2Double = Sngl_1 & " " & Sngl_2 Else S2Double = Sngl_1 End If End Function Private Function Fmale(num As Byte, Sex As Byte, Female()) As String Dim Two(1 To 4) As String Dim InSex As Byte Two(1) = "أحدَ" Two(2) = "اثنانِ" Two(3) = "إحدَى" Two(4) = "ة" Select Case Sex Case vMale: Select Case num Case 1: Fmale = Mid(Female(1), 1, 4) Case 2: Fmale = Two(2) Case 8: Fmale = Female(num) + "ي" + Two(4) Case 3 To 7, 9, 10: Fmale = Female(num) + Two(4) Case 11: Fmale = Two(1) + " " + Female(10) Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10) Case 13 To 19: Fmale = Female(num - 10) + Two(4) + " " + Female(10) End Select Case vFemale: Select Case num Case 1 To 10: Fmale = Female(num) Case 11: Fmale = Two(3) + " " + Female(10) + Two(4) Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4) Case 13 To 19: Fmale = Female(num - 10) + " " + Female(10) + Two(4) End Select End Select End Function Private Function Tens(num As Byte, Female()) As String Const Noon = "ونَ" Select Case num Case 2: Tens = Female(10) + Noon Case 3 To 9: Tens = Female(num) + Noon End Select End Function Private Function Hunds(num As Byte, Female()) As String Const Hund = "مائة" Select Case num Case 1: Hunds = Hund Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3) Case 3 To 9: Hunds = Female(num) + Hund End Select End Function Private Function Tenteen(num As Byte, ETens()) As String Const een = "een" num = num Mod 10 Select Case num Case 3 To 9: Tenteen = Mid(ETens(num), 1, Len(ETens(num)) - 1) + een End Select End Function Private Function EHunds(num As Byte, ESingle()) As String EHunds = ESingle(num) + " hundred" End Function Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String Const And_ As String * 1 = "و" Const Lang = vArabic Dim PartNum(0 To 7) As Long Dim Result1(0 To 8) As String Dim Parts_(0 To 13) As String Dim Female(1 To 10) As Variant Dim TempI As Byte Dim Sex2 As Byte Dim K As Byte Dim Only_ As String Dim OnlyPart As String Dim Part_ As String Dim TempS As String Dim Sngl_1 As String Dim Sngl_2 As String Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then AOnly = RTrim("لا شيءَ " & Single_) ' تم تغيير صفر إلى لا شيء Else AOnly = FracS & " " & Single_ End If Exit Function End If Female(1) = "واحدة" Female(2) = "اثنتانِ" Female(3) = "ثلاث" Female(4) = "أربع" Female(5) = "خمس" Female(6) = "ست" Female(7) = "سبع" Female(8) = "ثمان" Female(9) = "تسع" Female(10) = "عشر" Parts_(0) = "" Parts_(1) = "ألف" Parts_(2) = "مليونَ" Parts_(3) = "مليار" Parts_(4) = "ترليونَ" Parts_(5) = "كدرليونَ" Parts_(6) = "كوينتليونَ" Parts_(7) = "" Parts_(8) = "آلافٍ" Parts_(9) = "ملايينَ" Parts_(10) = "ملياراتٍ" Parts_(11) = "ترليوناتٍ" Parts_(12) = "كدرليوناتٍ" Parts_(13) = "كوينتليوناتٍ" K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" And InStr(2, Plural, Sngl_2) > 0 Then Sngl_2 = "" End If For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K Sex2 = Sex For K = 0 To (Parts - 1) If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = Hunds(CByte(N1), Female()) If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1) Select Case TempI Case 1 To 2: If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex Case 3 To 19: N3_ = Fmale(TempI, CByte(Sex), Female()) Case 20 To 99: N2_ = Tens(CByte(N2), Female()) If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female()) If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدَى" End Select OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang) '{------------------------------------------} If PartNum(K) > 100 Then Select Case TempI Case 1, 2: OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang) End Select End If '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = Parts_(Parts - K - 1) If Part_ <> "" Then Select Case TempI Case 2: Part_ = Part_ + "انِ" Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 7) Case 11 To 99: Part_ = Part_ + "اً" End Select End If End If '{------------------------------------------} If Part_ <> "" Then If TempI >= 1 And TempI <= 2 Then OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang) Else OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang) End If End If Result1(K) = OnlyPart Next K '{------------------------------------------} For K = 0 To Parts - 1 Only_ = AddAnd(Only_, Result1(K), "", And_, Lang) Next K If FracS <> "" Then If Only_ <> "" Then FracS = " " + FracS Only_ = AddAnd(Only_, FracS, "", And_, Lang) End If If Only_ <> "" Then If Mid(Only_, Len(Only_), 1) = "ا" Then If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If If TempS = "000" Then If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If End If '{------------------------------------------} If FracS = "" Then Select Case TempI Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang) End If Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If Case 11 To 99: If Sngl_1 <> "" Then Only_ = AddAnd(Only_, Sngl_1, "", "", Lang) N1_ = Mid(Only_, Len(Only_), 1) Select Case N1_ Case "ة", "ى", "أ", "ء", "اء" Case Else Only_ = Only_ + "اً" End Select N1_ = Mid(Only_, Len(Only_) - 2, 3) 'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24 If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then Only_ = Left(Only_, Len(Only_) - 1) End If If Sngl_2 <> "" Then If Right(Only_, 1) = "ا" Then Only_ = AddAnd(Only_, Sngl_2 & "اً", "", "", Lang) Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If End If End Select Else Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang) End If AOnly = (Only_) End Function Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant Dim Num_ As String Dim K As Byte Dim Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = CStr(InNum) K = InStr(1, Num_, ".", 1) If K > 0 Then Dec = Len(Num_) - K 'If Dec < 2 Then Dec = 2 Else Dec = 0 End If FType = FracType If FType <> 2 Then FType = 1 S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType) End Function Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _ Single_ As String, Plural As String, _ FSex As Byte, SFrac As String, PFrac As String, _ FracType As Byte) As Variant Dim Leng As Byte Dim Parts As Byte Dim K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String Dim And_ As String If IsNull(InNum) Then B_Only = Null Exit Function End If If Dec > 6 Then Dec = 6 Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0")) If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = "" If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1) FracVal = Val(FracS) Do While Len(FracS) < Dec + 2 FracS = Insert(FracS, "0", 1) Loop DoProcess: If FracVal = 0 Then FracS = "" FracNum = Trim(Mid(FracS, 3, Len(FracS))) If FracS <> "" Then Select Case FracType Case 2 Select Case Lang Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0"))) End Select Case 3 Select Case Lang Case vArabic: FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac) End Select Case 4 Leng = Len(FracNum) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng FracNum = Insert("0", FracNum, 1) Next K Select Case Lang Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType) End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) If Parts > 7 Then B_Only = InNum Exit Function End If For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracType = 3 Then And_ = "و " Else And_ = "و" If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang)) End Select End Select If Only <> "" Then Select Case Lang Case vArabic: B_Only = Only End Select End If End Function 'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث ' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات Function ArbNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = 2, _ Optional ByVal FractionType = 4, _ Optional ByVal CurrencySingle = "جنيه", _ Optional ByVal CurrencyPlural = "جنيهات", _ Optional ByVal CurrencySex = 0, _ Optional ByVal FractionSingle = "قرش", _ Optional ByVal FractionPlural = "قروش", _ Optional ByVal FractionSex = 0) As Variant Dim Negative As String If IsNull(InNum) Then ArbNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "سالبُ " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) End If ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 2 InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) 'If InNum <> Fix(InNum) Then If Val(Right(InNum, DecimalPlaces)) > 0 Then If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح Dim m m = " فقطُ لا غيرَ" ArbNum2Text = Negative & _ B_Only(CDec(myNz(InNum, 0)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) & m End Function[/center] انتقل الى صفحة الإكسيل واكتب في الخلية B6 اي رقم مثلا 50 وفي أي خليه أخرى ولتكن الخلية D6 اكتب الجملة التاليه =ArbNum2Text(B6;1;1;"درجـة";"درجـات";1;"جزء";"أجزاء";1) اضغط انتر سيظهر تفقيط الرقم وإذا أردنا الاستفادة من الكود في الماهيات نضع في الخليه D6 هذه الجمله =" فقط "&ArbNum2Text(B6; 2;3;"جنيه";"جنيهات";1;"قرش";"قروش";1) أو اكتب هذه الجمله = "الصافي : " & ArbNum2Text(B6) ودمتم في حفظ الله كود تفقيط مفيد باستخدامات مختلفة.rar

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

السلام عليكم ورحمة الله وبركاته إلى الأعضاء الكرام شكرا جزيلا لكل من ساعدني في هذا البرنامج وأخص بالذكر الاستاذ أبو خليل شكرا للجميع وجزاكم الله خيرا اسم المستخدم هو نفسه كلمة المرور الملف مقسم إلى ملفين عند فك الضغط اضغط على الجزء الأول واعمل استخراج وسوف يتم تجميع الملفين إلى ملف واحد شرح البرنامج تجده على الرابط التالي بسم الله توكلت على الله لابد من تحميل كافة المرفقات Follow up V3.part01.rar Follow up V3.part02.rar

فعلا المهندس سليم لم ينجح حاولت 3 محاولات لاني محتاج لمثل هذا الملف مثل الاخ طارح الموضوع غيرت الرقم من 857 الى 6000 ثم سحبتها من A3 الى H3 فظهؤت النتائج عند الصف الرابع غير صحيحة عبارة عن خطوط وسحبتها الى مستوى 6000 صف فلم ينجح

اذا في الموقع ابو حنين على ميكروسوفت السلام لقد ابدع فامتع

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

وعليك السلام اخي الكريم راجع التعليمات اخي الكريم العنوان لا يدل على طلبك المهم في المرفق تجد طلبك لعله يكون المطلوب اخفاء واظهار.rar

هذا الكود لاظافة ورقة عمل بشرط كتابة اسم المريض في الخلية D3 Sub Add_Sheets() Dim sh As Worksheet Sheets.Add After:=Sheets(Sheets.Count) Set sh = ActiveSheet With sh .Name = Sheets("الرئيسية").Range("D3") Sheets("الرئيسية").Columns("A:L").Copy .Range("A1") End With End Sub

تمت كتابتها يدويا للمعادله الاولى ثم السحب لأسفل

الأخ الكريم محمد الالفى السلام عليكم جرب المعادلة التالية لعلها تكون المطلوبة =IF(COUNTIF(E$3:E3;E3)=1;"";"مكرر "&MAX(SUMIF($E$3:E3;E3;$F$3:F3);SUMIF($E$3:E3;E3;$G$3:G3)))

حاولنا ان ندمج بين ورقتي العمل وكتبنا معادلة خطا أو صح عندما تتساوى مجموع g3 مع j2 لكل صفحة اصناف1.rar

اخى الكريم تفضل مرفقك حسب برنامج الترجمة ستجد استعلام باسم Elsayed فيه ترجمة كل اسمائك beirut ifradi akeli.rar محمد يا عصام فكك من الخمسة جنيه المقطعة دى احنا مصريين زى بعض ههههههههههه متقولش كدا على نفسك تانى احنا بنتناقش .. انا اللى كنت متنرفز شوية وردودى مستفزة كل سنة وانت طيب

جرب المعادلة التالية =IF(OR(SUMIF($E$3:$E$456,E3,$F$3:$F$23)>=2,SUMIF($E$3:$E$456,E3,$G$3:$G$456)>=2),SUMPRODUCT(--($E$3:$E$456=E3)),"")

تفضل الصق هذا الكود في حدث عند التحميل للنموذج : If day(Date) = 1 Then DoCmd.OpenForm "frm1", acNormal

تم عمل موضوع جديد وهذا الرابط

الحمد لله الذي بنعمته تتم الصالحات والحمد لله أن تم المطلوب على خير تقبل تحياتي وكل عام وأنت بخير

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

جاري التحديث ....

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

اشكرك استاذي الفاضل ياسر اولا :- لعدم رفع الملف كبير الحجم لم استطع رفعه وثانيا :- الكود الذي كتبته هذا ما اريده فعلا وجزاك الله كل خير وفي ميزان حسناتك

فعلا اخي الكريم المشكلة كانت من الانترنت اضم صوتي لاصوات الاساتذة رمهان و محمد سلامة والكود في كلا الحالتين ( وجود تحديث او عدم وجود تحديث ) يقوم بحذف الجدول table_1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

يكون بهذه الطريقة Private Sub UserForm_Activate() Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.Name <> "5" Then Me.ComboBox1.AddItem ws.Name Next End Sub

وعليكم السلام أخي حسين مأمون (لكم أنا سعيد بتغيير لقبك) بالنسبة للكود سيان يوضع هنا أو هنا ولكن سيلزم تغيير بسيط في الكود في السطرين الخاصين بتعيين أسماء المصنفات .. في حالة أردته على Aman ستضطر إلى تغيير الامتداد xlsx إلى xlsm لتحتفظ بالكود .. وفي هذه الحالة سيتغير WB1 ليكون هو ThisWorkbook ، والمتغير WB2 سيكون اسم المصنف الثاني مضاف إليه الامتداد .. أرجو أن تكون الأمور واضحة إن شاء الله

أخي الكريم أبو حمادة لاأدري إذا كنت اطلعت على الشرح أم لا .. حاول تدرس أي كود عايز تطبقه عشان تقدر تتعلم شيء جديد عموماً بالنسبة لطلبك السطر المطلوب لتحديد النطاق الخاص بالبيانات هو السطر التالي MyArray = iSh.Range("S10:AB" & iSh.Cells(Rows.Count, 21).End(xlUp).Row).Value ولا تنسى أن تقوم بتغيير أسماء أوراق العمل في الكود .. كل سطر له أهميته ولازم تراجع الكود وتشوف الأسطر الموجودة فيه .. راجع الشرح إذا وجدت وقت لذلك

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

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

مرحبا جرب هذا الكود في موديل و اجعل له زر Sub sCopyTo() Dim iSh As Worksheet, Sh As Worksheet, MyArray, MySheet, I As Long, R As Long, X As Long Dim Wrd1 As String, Wrd2 As String, Wrd3 As String Set iSh = Sheets("A"): Set Sh = Sheets("y") Wrd1 = "حول": Wrd2 = "معلق": Wrd3 = "معلقة" MyArray = iSh.Range("S10:AB" & iSh.Cells(Rows.Count, 21).End(xlUp).Row).Value ReDim MySheet(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2)) For I = LBound(MyArray, 1) To UBound(MyArray, 1) If MyArray(I, 1) <> Wrd1 And MyArray(I, 4) <> Wrd2 And MyArray(I, 4) <> Wrd3 Then For X = 3 To 10 MySheet(R + 1, X) = MyArray(I, X) Next X R = R + 1 End If Next I Sh.Range("A10").Resize(R, UBound(MySheet, 2)).Value = MySheet End Sub

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

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

الأخ الكريم محبوب أعتذر عن التأخر في الرد عليك ، فقد كنت منشغلاً .. إليك الشرح عله يفيدك إن شاء الله Sub YasserKhalil() 'تعريف المتغيرات Dim WBK As Workbook Dim SH As Worksheet, WS As Worksheet, Cell As Range 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء خاصية رسائل التنبيه Application.DisplayAlerts = False 'سطر لفتح المصنف المسمى حسابات العملاء لجلب البيانات منه Set WBK = Workbooks.Open(ThisWorkbook.Path & "\حسابات العملاء.xlsx") 'حلقة تكرارية لكل أوراق العمل في المصنف الحالي الذي يحوي الكود For Each SH In ThisWorkbook.Sheets 'سطر لاستثناء ورقة العمل المسماة الفهرس من الحلقة التكرارية If SH.Name <> "الفهرس" Then 'مسح محتويات النطاقات المراد جلب البيانات إليها SH.Range("C6:F99,H6:I99").ClearContents 'حلقة تكرارية لكل أوراق العمل في المصنف المسمى حسابات العملاء For Each WS In WBK.Sheets 'سطر لاستثناء ورقة العمل المسماة الفهرس الرئيسي من الحلقة التكرارية If WS.Name <> "الفهرس الرئيسى" Then 'بدء التعامل مع كل ورقة عمل على حدا With WS 'إذا كانت أول خلية تحتوي على التواريخ فارغة يتم الانتقال لورقة العمل التالية If IsEmpty(.Range("A6")) Then GoTo 1 'سطر لتفادي حدوث خطأ أي استمرار عمل الكود في حالة حدوث خطأ On Error Resume Next 'حلقة تكرارية لنطاق التواريخ For Each Cell In .Range("A6:A" & .Cells(Rows.Count, 1).End(xlUp).Row) 'إذا كانت الخلية التي تحتوي على التاريخ ، الشهر بها يساوي رقم الشهر في ورقة العمل في المصنف الحالي 'وكذلك السنة الموجودة في التاريخ تساوي سنة 2015 يتم تنفيذ الأسطر التالية If Month(Cell.Value) = MonthNumber(SH.Name) And Year(Cell.Value) = 2015 Then 'يتم جلب التاريخ ووضعه في العمود الثامن في أوراق العمل في المصنف الحالي SH.Range("H" & SH.Cells(99, 8).End(xlUp).Row + 1) = Cell.Value 'يتم جلب اسم العميل ووضعه في العمود الثالث في أوراق العمل في المصنف الحالي SH.Range("C" & SH.Cells(99, 3).End(xlUp).Row + 1) = .Range("C2").Value 'يتم جلب قيمة القسط ووضعها في العمود الخامس في أوراق العمل في المصنف الحالي SH.Range("E" & SH.Cells(99, 5).End(xlUp).Row + 1) = Cell.Offset(, 2) 'يتم جلب قيمة الكوبري ووضعها في العمود السادس في أوراق العمل في المصنف الحالي SH.Range("F" & SH.Cells(99, 6).End(xlUp).Row + 1) = Cell.Offset(, 3) 'يتم جلب رقم التليفون ووضعه في العمود التاسع في أوراق العمل في المصنف الحالي SH.Range("I" & SH.Cells(99, 9).End(xlUp).Row + 1) = .Range("M8").Value 'انتهاء أسطر الشرط End If 'الانتقال للخلية التالية التي تحوي تاريخ Next Cell 'انتهاء التعامل مع ورقة العمل من المصنف المسمى حسابات العملاء استعداداً للتعامل مع ورقة عمل جديدة 1 End With End If 'الانتقال لورقة عمل جديدة في المنصف المسمى حسابات العملاء Next WS End If 'الانتقال لورقة عمل جديدة في المصنف الحالي Next SH 'إغلاق المصنف المسمى حسابات العملاء بدون حفظ التغييرات WBK.Close SaveChanges:=False 'إعادة تفعيل خاصية رسائل التنبيه Application.DisplayAlerts = True 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub تقبل تحياتي

تفضل أخي الكريم ... كل مافي هذا المثال تعلمته من أساتذتي الكرام في هذا الصرح الرائع ... البريد الوارد والصادر 30.rar

لابد من تحميل كافة المرفقات

اهلا و سهلا بك اخي الكريم

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

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

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

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

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

اخي رضوان بارك الله فيك على هذه الملاحظة تم التعديل بموجبها قم بالتجربه الان وانظر هل تحسن الوضع الى الافضل zaChangeResolution2006_UP.rar اخي طارق العيد واصل تجاربك وان احتجت اي مساعده فلا تتردد في السؤال عنها

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