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

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

الحمد لله

المرفق حسب فهمي لمطلبك: DC_02.xlsx

السلام عليكم إخواني أريد المشاركة مع أستاذي الفاضل Eng.Qassim لقد أضفت إضافة عل الدلة التي استفدنا منها جزاكم الله خيرا فأوفت بالغرض و الحمد لله و هي كما يلي : Public Function RoundNmber(Rou As Double) As Double If Rou - Int(Rou) = 0 Then RoundNmber = Int(Rou) Else If Rou - Int(Rou) <= 0.5 Then RoundNmber = Int(Rou) + 0.5 Else RoundNmber = Int(Rou) + 1 End If End If End Function جزاكم الله كل الخير و شكرا

وهذه طريقة اخرى .... Database1 (33).accdb

تفضل Database1 (33).accdb

كإجابة مباشرة .. نعم ممكن بجعل تنسيق الخلية هكذا ( A0\ ) : والنتيجة :

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

السلام عليكم اخى الفاضل الاسباب كثيرة منها ربما الإصدارين مثبتان بشكل صحيح وتوجد تعارضات بينهما ربما عدم وجود Microsoft Forms 2.0 Object Library ربما التحديثات التلقائية لأحد الإصدارين إلى تعطيل أو إفساد إعدادات الإصدار الآخر على كل حال ارفاق ملف يقفل باب ربما في انتظار ارفاق ملفك لاصدار 2016 وهو الموجود حاليا على جهازي لك كل الود والاحنرام

تم التعديل لإظهار الفورم OK قاعدة 2025.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim n As Range, f As String, count As Integer, i As Integer If Not Intersect(Target, Me.Range("A1:B2")) Is Nothing Then Dim WS As Worksheet: Set WS = Sheets("data") Dim xRow As Range: Set xRow = WS.Range("A1:J1") Dim tmp As Integer: tmp = xRow.Column xRow.ClearContents For Each n In Me.Range("A1:A2") If n.Value <> "" Then f = n.Value count = n.Offset(0, 1).Value For i = 1 To count If tmp > xRow.Columns.count + xRow.Column - 1 Then Exit Sub WS.Cells(xRow.Row, tmp).Value = f tmp = tmp + 1 Next i End If Next n End If End Sub test2.xlsb

وعليكم السلام ورحمة الله وبركاته تفضل test1.xlsx

مشاركة مع الإخوة الأعزاء 🙂 هذه طريقتي في تضمين الخطوط في البرنامج .. 1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات : 2 - في الموديول كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات : 3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول . الملف : Add Fonts.accdb

وعليكم السلام ورحمة الله تعالى وبركاته كما سبق الدكر من الأستاد @عبدالله بشير عبدالله طلبك غير واضح إظافة أن أرقام الأعمدة على الملف تتواجد في الصف 3 ليس 2 مجرد تخمين ربما تقصد جلب بيانات العمود بشرط إدخال قيمة رؤوس الأعمدة (رقم العمود) جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Variant, tmp As Variant, lastRow As Long, a As Long, Clé As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, WS.Range("AQ3:BO3")) Is Nothing Then lastRow = WS.Columns("A:Z").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row OnRng = WS.Range("A4:Z" & lastRow).Value tmp = WS.Range("A3:Z3").Value Clé = Target.Value Application.ScreenUpdating = False If IsEmpty(Target.Value) Then WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)).ClearContents Else For a = 1 To UBound(tmp, 2) If tmp(1, a) = Clé Then With WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)) .ClearContents .Value = Application.Index(OnRng, 0, a) End With Exit For End If Next a End If If a > UBound(tmp, 2) Then Target.ClearContents: MsgBox "لم يتم العثور على " & _ Target.Value & " في قاعدة البيانات", vbExclamation, "إنتبـــاه" End If Application.ScreenUpdating = True End Sub استخراج الاعمدة.xlsm

قم بنسخ الأداة إلى مجلد C:\WINDOWS\SysWOW64 ثم افتح Command Prompt كمسؤول وقم بتسجيل الأداة regsvr32 RotateLabelVer2.ocx والآن يمكنك في برنامج إضافة الأداة ستظهر الأداة بهذا الاسم: يمكنك تعديل نوع الخط والحجم واللون من صندوق الخصائص RotateLabelVer2.zip

ربما يكون هذا هو المطلوب الثاني فلترة_2.xlsm

السلام عليكم ورحمة الله وبركات اساتذتى الكرام ارجو تعديل الكود الخاص بالفورم (submid) لادراج الصورة فى الخلية Insert the image (h) ولكم منى جزيل الشكر Submit - Copy.rar

أخي الكريم أبو راكان بالنسبة لطلبك لنفترض أن الفورم يحتوي على تكست بوكس للاسم المطلوب إدراجه ، والمطلوب إدراجه في العمود G في نفس صف الخلية التي سيتم إدراج صورة بها بما أن العمود الذي يتم إدراج صورة فيه كما في المثال العمو V والعمود المطلوب إدراج الاسم فيه هو العمود G أي يسبق العمود V بـ 17 عمود .. فيستلزم الأمر إضافة سطر واحد في نهاية الكود التالي Private Sub CommandButton2_Click() Dim R As Range, LR As Long ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_HIDE If LastRowPic(22) = 0 Then LR = Cells(Rows.Count, "V").End(xlUp).Row + 1 Else LR = LastRowPic(22) Set R = Range("V" & LR) ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_SHOW With ActiveSheet.Pictures.Insert(LastSelectedFilePath) .ShapeRange.LockAspectRatio = msoFalse .Top = R.Top .Left = R.Left .Width = R.Width .Height = R.Height End With R.Offset(0, -19).Value = textbox1.Value End Sub

أخي الكريم محمد علي ضع الكود التالي في موديول عادي Sub ShowForm() UserForm1.Show End Sub Function LastRowPic(ColumnNumber As Long) As Long Dim Arr, Pic As Shape, I As Long ReDim Arr(1 To Columns.Count) For Each Pic In ActiveSheet.Shapes With Pic For I = .TopLeftCell.Column To .BottomRightCell.Column Arr(I) = Application.Max(.BottomRightCell.Row, IIf(Arr(I) = "", 0, Arr(I))) Next I End With Next Pic LastRowPic = Arr(ColumnNumber) End Function ثم قم بوضع الكود التالي في حدث الفورم #If VBA7 Then Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #Else Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If Private Const SW_HIDE As Long = 0 Private Const SW_SHOW As Long = 5 Private LastSelectedFilePath As String Private Sub CommandButton1_Click() Dim strFileName As String strFileName = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False) If strFileName = "False" Then MsgBox "File Not Selected!" Else Me.Image1.Picture = LoadPicture(strFileName) LastSelectedFilePath = strFileName Me.Repaint End If End Sub Private Sub CommandButton2_Click() Dim R As Range, LR As Long ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_HIDE If LastRowPic(22) = 0 Then LR = Cells(Rows.Count, "V").End(xlUp).Row + 1 Else LR = LastRowPic(22) Set R = Range("V" & LR) ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_SHOW With ActiveSheet.Pictures.Insert(LastSelectedFilePath) .ShapeRange.LockAspectRatio = msoFalse .Top = R.Top .Left = R.Left .Width = R.Width .Height = R.Height End With End Sub وإليك الملف المرفق فيه تطبيق للأكواد أرجو ان يكون المطلوب إن شاء الله Load Picture On UserForm Using Dialog & Insert Image To Worksheet YasserKhalil.rar

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

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