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

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

السلام عليكم من المعروف أن الاكسل يسمح باضافة صورة خلفية لورقة العمل عن طريق 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 معاينة_مع_الطباعة() ActiveWindow.SelectedSheets.PrintPreview A = MsgBox("هل تود الطباعة بعد المعاينة؟", vbYesNo + vbQuestion, "طباعة") If A = vbYes Then With ActiveSheet .PrintOut End With End If Range("A1").Activate End Sub ودمتم في حفظ الله معاينة طباعة مع امكانية الطباعه.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

اخي الكريم الطيب سعد في المرفقات ملف قمت بتصميمه سابقاً ادخال البيانات عن طريق الفورم - زر ادخال البيانات ومن داخل الفورم ترقيم تلقائي للقيد بحث عن الحساب بالاسم اذا ادخلت مبلغاً مديناً فهو سند صرف اذا ادخلت مبلغاً دائناً فهو سند قبض بقي ينقصك رقم السند.. وهذا يمكن تصميمه فيما بعد في ورقة كشف حساب يمكن استعراض أي حساب ... بالاضافة الى رصيد الحساب وكذلك رصيد الصنودوق طلبك عن اليومية العامة (ورقة يومية الصندوق هي تمثل اليومية العامة ) طلبك عن الاستعلام ( هل تريد الاستعلام عن السند عن طريق رقم السند ؟؟؟) *واذا لم يُلَبِّ الملف طلبك فالرجاء شرح مفصل عن طلباتك ملاحظة على ملفك الثاني : اذا كان لديك صندوق واحد فقط فيكون شكل اليومية كا ذكرت انت في الملف الاول اما اذا كان لديك اكثر من صندوق فالامر يختلف تحياتي يومية صندوق مع كشف حساب.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 سيكون اسم المصنف الثاني مضاف إليه الامتداد .. أرجو أن تكون الأمور واضحة إن شاء الله

عوداً حميداً أخي الكريم أبو حمادة ... الأخ الغالي أبو حنين قدم لنا كود في منتهى منتهى الجمال والروعة .. ومن روعته وجدت نفسي أقوم بوضع شرح لأسطره بارك الله فيك وجزاك الله كل خير على هذه الهدايا القيمة ، وكل عام وأنت بخير عدلت تعديل طفيف للغاية بحيث تكون مصفوفة النتائج تحتوي على النتائج المطلوبة فقط وهي تبدأ من 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

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

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

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

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

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

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

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

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