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

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

السلام عليكم تفضل أخي الكريم عسي أن يكون هذا ماتريد تقييم الطلاب.xlsx

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

السؤال : كيف يمكن تثبيت خلايا معينة فى المعادلة عند عمل سحب أو Drag ؟ الاجابة : علم علي الجزء المراد تثبيته في المعادلة و هو هنا a1 ثم اضغط علي f4 ستظهر علامتين $ قبل رقم الصف و العمود و معني ذلك ان الصف و العمود ثابتين عند النسخ أو السحب و بضغطة أخري و ضغطة ثالثة يتم تثبيت الصف فقط أو العمود فقط و ما يناسب الحالة قد يكون هو اما تثبيت الصف و العمود $a$1 أو تثبيت الصف فقط a$1 أو تثبيت العمود فقط $a1

كان (الأستاذ أبو عبد الملك السوفي) طلب كود لجعل ال Frame شفافاً ففكرت بشرح الموضوع والأكواد كلها وكيفية وضعها من خلال ثلاث حالات الحالة الأولى :- لجعل frame شفافاً ليعطى شكل صفحة الإكسل التى خلفه تقوم بعمل Class Modules ومن الخصائص تقوم بتغيير اسمه إلى CTransparentFrameMaker ونقوم بوضع هذا الكود به Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type PICTDESC Size As Long Type As Long #If VBA7 Then hPic As LongPtr #Else hPic As Long #End If hPal As Long End Type #If VBA7 Then 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private hMemDc As LongPtr #Else 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private hMemDc As Long #End If Private Const SRCCOPY = &HCC0020 Private Const PICTYPE_BITMAP = &H1 Private Const SM_CYFRAME = 33 Private Const HORZ = 8 Private Const VERT = 10 Private arFramesArray() As Control Private i As Long Private WithEvents oForm As UserForm Private Sub Class_Initialize() i = -1 VBA.AppActivate Application.Caption Call TakeFirstScreenSnapShot End Sub Private Sub Class_Terminate() DeleteDC hMemDc End Sub Public Sub AddFrame(ByVal Frame As Control) i = i + 1 ReDim Preserve arFramesArray(i) Set arFramesArray(i) = Frame Set oForm = Frame.Parent End Sub Private Sub UpdateFrameBackGround(ByVal frm As Control) #If VBA7 Then Dim hMemDc2 As LongPtr, hMemBmp2 As LongPtr #Else Dim hMemDc2 As Long, hMemBmp2 As Long #End If Dim tFrameRect As RECT Dim oPic As IPicture On Error Resume Next GetWindowRect frm.[_GethWnd], tFrameRect With tFrameRect hMemDc2 = CreateCompatibleDC(hMemDc) hMemBmp2 = CreateCompatibleBitmap(hMemDc, .Right - .Left, .Bottom - .Top) SelectObject hMemDc2, hMemBmp2 BitBlt hMemDc2, 0, 0, .Right - .Left, .Bottom - .Top, hMemDc, .Left, .Top + GetSystemMetrics(SM_CYFRAME), SRCCOPY End With Set oPic = CreatePic(hMemBmp2) SavePicture oPic, Environ("Temp") & "\" & frm.Name & ".bmp" Set frm.Picture = LoadPicture(Environ("Temp") & "\" & frm.Name & ".bmp") Kill Environ("Temp") & "\" & frm.Name & ".bmp" DeleteObject hMemBmp2 DeleteDC hMemDc2 End Sub #If VBA7 Then Private Function CreatePic(ByVal hbmp As LongPtr) As IPicture #Else Private Function CreatePic(ByVal hbmp As Long) As IPicture #End If Dim IID_IDispatch As GUID Dim uPicinfo As PICTDESC Dim IPic As IPicture With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With uPicinfo .Size = Len(uPicinfo) ' .Type = PICTYPE_BITMAP .hPic = hbmp .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, 1, IPic Set CreatePic = IPic End Function Private Sub TakeFirstScreenSnapShot() #If VBA7 Then Dim scrDc As LongPtr, hMemBmp As LongPtr, hwnd As LongPtr #Else Dim scrDc As Long, hMemBmp As Long, hwnd As Long #End If Dim w As Long Dim h As Long scrDc = GetDC(0) w = GetDeviceCaps(scrDc, HORZ) h = GetDeviceCaps(scrDc, VERT) hMemDc = CreateCompatibleDC(scrDc) hMemBmp = CreateCompatibleBitmap(scrDc, w, h) SelectObject hMemDc, hMemBmp BitBlt hMemDc, 0, 0, w, h, scrDc, 0, 0, SRCCOPY ReleaseDC 0, scrDc DeleteObject hMemBmp End Sub Private Sub oForm_Layout() Dim k As Long For k = LBound(arFramesArray) To UBound(arFramesArray) UpdateFrameBackGround arFramesArray(k) Next End Sub ثم تقوم بوضع هذا الكود داخل اليوزرفورم عن طريق الضغط عليه دوبل كليك Option Explicit Private oCTransparent As CTransparentFrameMaker Private Sub UserForm_Initialize() Dim oCtl As Control Set oCTransparent = New CTransparentFrameMaker For Each oCtl In Me.Controls If TypeName(oCtl) = "Frame" Then oCTransparent.AddFrame oCtl End If Next End Sub وهذا الملف به تطبيقاً على الفكرة Frame.xlsm ------------------------------------------------------------------------------------------------------------------------------ الحالة الثانية :- لجعل Frame شفافاً بلون Userform الذى اسفله نقوم بوضع هذا الكود بداخل ال userform بالضغط دوبل كليك عليه Private Sub UserForm_activate() With Frame1 .BackColor = BackColor End With End Sub وهذا ملف للتوضيح Frame1.xlsm ----------------------------------------------------------------------------------------------------- الحالة الثالثة :- لجعل userform وال frame شفافاً (وهذا الكود والملف من مشاركات الأستاذ ali mohamed ali ) نقوم بوضع هذا الكود داخل اليوزرفورم عن طريق الضغط على اليوزرفورم دوبل كليك Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Const GWL_EXSTYLE = (-20) Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Dim hWnd As Long Private Sub UserForm_activate() Dim ufcap As String hWnd = FindWindow("ThunderDFrame", ufcap) hosami Me, 150 End Sub Private Function hosami(frm As UserForm, Level As Byte) As Boolean SetWindowLong hWnd, GWL_EXSTYLE, WS_EX_LAYERED SetLayeredWindowAttributes hWnd, 0, Level, LWA_ALPHA End Function وهذا الملف به تطبيقا للفكرة شفافية اليوزرفورم .xlsm

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

هذا الرابط .. حول إضافة المراجع آلياً للبرنامج .. و أحسب أنه الأفضل بناء على ما جاء التعليقات ، لم أجربه و ربما قد أحتاج للمساعدة عند تطبيقه . https://www.tek-tips.com/viewthread.cfm?qid=903662 Maybe these examples will help you. Function FixUpRefs() Dim loRef As Access.Reference Dim intCount As Integer Dim intX As Integer Dim blnBroke As Boolean Dim strPath As String On Error Resume Next 'Count the number of references in the database intCount = Access.References.Count 'Loop through each reference in the database 'and determine if the reference is broken. 'If it is broken, remove the Reference and add it back. Debug.Print "----------------- References found -----------------------" Debug.Print " reference count = "; intCount For intX = intCount To 1 Step -1 Set loRef = Access.References(intX) With loRef Debug.Print " reference = "; .FullPath blnBroke = .IsBroken If blnBroke = True Or Err <> 0 Then strPath = .FullPath Debug.Print " ***** Err = "; Err; " and Broke = "; blnBroke With Access.References .Remove loRef Debug.Print "path name = "; strPath .AddFromFile strPath End With End If End With Next '''Access.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll" Set loRef = Nothing ' Call a hidden SysCmd to automatically compile/save all modules. Call SysCmd(504, 16483) End Function Function AddRefs() Dim loRef As Access.Reference Dim intCount As Integer Dim intX As Integer Dim blnBroke As Boolean Dim strPath As String On Error Resume Next 'Loop through each reference in the database 'Add all references Debug.Print "----------------- Add References -----------------------" With Access.References .AddFromFile "C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll" .AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\vbe6.dll" .AddFromFile "C:\Program Files\Microsoft Office\Office\msacc9.olb" .AddFromFile "C:\Program Files\Common Files\System\ado\msado15.dll" .AddFromFile "C:\Program Files\Common Files\System\ado\msado25.tlb" .AddFromFile "C:\Program Files\Common Files\System\ado\msadox.dll" .AddFromFile "C:\WINNT\System32\stdole2.tlb" .AddFromFile "C:\WINNT\System32\scrrun.dll" End With ' Call a hidden SysCmd to automatically compile/save all modules. Call SysCmd(504, 16483) End Function و يبقى السؤال قائماً

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

اولا الله يسامحك انك تجيب تسميات غير موجود في الجدول المطلوب اتفضل شوف التعديل Expr6: IIf([Stype]="سند صرف موظف";DLookUp("[EmployeeName]";"Employee_T";"[EmID]= " & [EmployeeID] & " ");IIf([Stype]="سند صرف عميل";DLookUp("[CustomerName]";"CustomersT";"[CustomerID]= " & [CustomersID] & " ");IIf([Stype]="سند صرف المصروفات";DLookUp("[ExpenseName]";"ExpenseName";"[ExpenseID]= " & [ExpenseID] & " ");IIf([Stype]="سند صرف مورد";DLookUp("[SupplierName]";"SuppliersT";"[SupplierID]= " & [SuppliersID] & " ")))))

بارك الله في الجميع اخي kanory

جزاك الله الف خير .. الحمد لله قدرت اخلص التدريب وهركز على المعلومات الي انت قلتها هنا عشان استخدمها وقت الحاجة .. بارك الله فيك مرة اخرى استاذي الكريم وهذا نفس الحل الي انت قدمته لي باللغة الانجليزية لمن يهتم https://exceljet.net/formula/sumifs-with-multiple-criteria-and-or-logic

الطريقة التي استخدمتها هي الصحيحة وهي انك جعلت مجلد خاص للصورة وتم ربط عرض الصورة من المجلد داخل النموذج .... بذلك لن تكبر حجم قاعدة البيانات لأنك فقط قم بكتابة رابط الصورة فقط ...... أما لو أدرجت الصورة في قاعدة البيانات مباشرة برأي الشخصي تكون ارتكبت خطأ فادح لأان حجم قاعدة البيانات تتضاعف بسبب عدد من الصور .. يؤدي ذلك بعد فترة لتلف القاعدة للاسف ( وهذا رأي الشخصي )

بارك الله في أخي @ابو ياسين المشولي

تم حل المشكله كانت مشله ابو زاهر في التركز هو غير اسم النموذج من عربي الى انجليزي ولم يغير الكود

سنفترض ان تسمية الحقل الاسم عندك هز (MyNmae) استحدم هذا الكود في حدث الحالي Private Sub Form_Current() If Len(Me.MyName & vbNullString) > 0 Then Me.MyName.Locked = True Me.MyName.Enabled = False Else Me.MyName.Locked = False Me.MyName.Enabled = True End If End Sub

اتفضل اليك هذا المورد (1).rar

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

أخى محمود عليك الشرح المراد وتحديده بالتفصيل فالموضوع بهذه الطريقة غامض,لأنك لا تقوم بتحديد راس الأعمدة المطلوب استدعائها بصفحة استعلام كما ان هناك عدة اعمدة بها تواريخ مثل العمود L & W & AG & AJ من أى عمود من هذه الأعمدة يتم جلب البيانات بناءا على هذا التاريخ اخى الكريم عندما تقوم بطرح اى مشاركة عليك بوضع التفاصيل كاملة حتى لا ينصرفوا الأساتذة عن مساعدتك لأنك لا تقوم بشرح وتوضيح طلبك بدقة بارك الله فيك

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

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

السلام عليكم أخي الكريم مرفق مجلد به 32 ملف رمزي غير الملف الأساسي "Report.xlsm" ستجد زرين لكل واحد منهما كود الأول يعمل لك ليستة بالملفات الموجودة بالمجلد اللي موجود به الملف الأساسي "Report.xlsm" يجب أن تضغط عليه أولا ليعطيك قائمة بالملفات الموجودة بالمجلد بداية من الخلية B4 نزولا للأسفل ثم الزر الثاني يعمل لك الهايبر لينك للملفات الموجودة بالمجلد وموجود إسمها بالملف الأساسي "Report.xlsm" تفضل المجلد ولو لك أسئلة لاتتردد TEST.rar

رائع بارك الله فيك

اتفضل الملف اهو والمعادلة فى المثال 3 تدريب عملي على الدوال الشرطية -SUM - SUMIF - SUMIFS.xlsx

استخدم الدالة دى وحطها فى C3 وانزل بيها اتوفيل لأخر خلية فى بيانات =IF(A3=1,100%,IF(A4="",1%,C2-(1/117))) على سبيل المثال انت لو عندك جدول فيه 100 طالب هتقول 1/100 لو 60 هتقول 1/60 وهكذا واول رقم هيحصل على 100 واخر رقم هيحصل على 1 وبالتالى الجدول التانى هتكون المعادلة كالأتى فى H3 =IF(H3=1,100%,IF(H4="",1%,J2-(1/12)))

أخي الكريم اعتقد يمكن ذلك بكود لنسخ هذه المراجع من جهازك كمبرمج ثم اضافتها لجهاز العميل .....

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

تفضل أخى عمر ضاحى okk_TEST2.xlsm

القي نظرة الى هذا لعله يفيدك

Sub MoveData() Dim EndRow As Long Dim TR, TR1 If Sheets("Invoice").Range("B8").Value = "" Or Sheets("Invoice").Range("F8").Value = "" Or Sheets("Invoice").Range("B11").Value = "" Or Sheets("Invoice").Range("B13").Value = "" Then MsgBox prompt:="ÊÃßÏ ãä ÅÏÎÇá ßÇÝÉ ÇáÈíÇäÇÊ", Title:="ÎØÃ" Else For TR1 = 1 To 9999 If Sheets("List").Cells(TR1, 1) <> "" _ And Val(Sheets("List").Cells(TR1, 1)) > 0 _ And Sheets("List").Cells(TR1, 2) = "" Then TR = TR1 GoTo 7 End If Next 7 Sheets("List").Cells(TR, 2).Value = Sheets("Invoice").Range("B8").Value Sheets("List").Cells(TR, 3).Value = Sheets("Invoice").Range("F8").Value Sheets("List").Cells(TR, 4).Value = Sheets("Invoice").Range("B11").Value Sheets("List").Cells(TR, 5).Value = Sheets("Invoice").Range("B13").Value Sheets("List").Cells(TR, 6).Value = Sheets("Invoice").Range("F13").Value Sheets("Invoice").Range("B8,F8,B11,B13,F13").ClearContents MsgBox prompt:="Êã ÊÑÍíá ÇáÈíÇäÇÊ ÈäÌÇÍ", Title:="ÑÓÇáÉ ÊÃßíÏ" End If End Sub

السلام عليكم الترتيب يمكنك عمله في الاستعلامات ومستقبلا في التقارير الترتيب في الجداول غير مهم عمل مفتاح (او مفهرس) ترقيم تلقائي في الجدول مهم

جرب هذا تم ضبط معادلة الرصيد 4455888.xlsm

الشكر لأستاذ على انه عدلك الكود .. وانا عدلتلك الجزء الخاص بالرصيد هيظهرك القيمة بناء على الوارد + المرتجع + اول المدة والافضل لك برضه استخدام الفلترة 4455888 (3).rar

بارك الله فيك استاذ سليم رائع

هذه المعادلة في F9 و اسحب نزولاً =MID(C9,1,FIND("/",C9)-1) أو هذه =REPLACE(C9,FIND("/",C9),50,"")

تفضل استخراج اسم الفصل فقط والغاء ما بعد الخط المائل.xlsx