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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاتة اهلا بكم اعضاء المنتدى الكرام اعتذر جدا للغياب الطويل عن المنتدى ولكن اشتقت اليكم فقولت ارجع بكود ممكن يفيد البعض فى عملة يعتبر البحث عن البيانات من الامور التى يبحث عنها كل مستخدمى الاكسل حيث انها تسهل عليهم اعمالهم وتحليل البيانات لديهم ولكن اذا كان لديك بيانات كثيرة جدا فى شيت الاكسل فالامر هنا يكون شاق ومرهق ومن هنا قررنا انشاء كود بحث من خلال اليوزرفورم يقوم بالبحث عن البيانات وتلوين واظهار نتائج البحث يتم وضع الكود فى حدث التكست بوكس Dim Itemsaerch As String Dim rng As Range Dim cell As Range Dim lr As Long Sheet1.Cells.Interior.Pattern = xlNone Itemsaerch = Me.TextBox1.Value lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row Set rng = Sheet1.Range("a2:a" & lr) For Each cell In rng If InStr(1, cell.Value, Itemsaerch) > 0 Then cell.Interior.Color = vbGreen End If Next cell If Me.TextBox1.Value = "" Then Sheet1.Cells.Interior.Pattern = xlNone ملف العمل فورم بحث جديد وتلوين نتائج البحث.xlsm

ماذا تقصد بكاملة ؟ هل تقصد يظهر التقدير العام لكل شهر في سطر واحد ؟ ام تريد جميع بنود التقييم خلال 12 شهر اي 120 سطر ؟ على كل ارفع لك المرفق بعد اصلاح الخلل EvaluationEmpUp2.rar

السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم printing Sub FilterByDate() Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing Dim MinDate As Date, MaxDate As Date, lr As Long Dim a As Range, r As Long MinDate = desWS.[d2]: MaxDate = desWS.[f2] Application.ScreenUpdating = False If MinDate > MaxDate Then: Exit Sub If Len(desWS.[f2]) > 0 And IsDate(desWS.[d2]) Then If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A7:K7") .AutoFilter 3, ">=" & CLng(MinDate), 1, "<=" & CLng(MaxDate) lr = WS.Columns("A:K").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A" & lr & ":k" & lr).SpecialCells(xlCellTypeVisible) If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then desWS.Range("A5:K" & Rows.Count).Clear With rng Cpt = Split("A,B,C,D,E,F,G,H,I,J,k", ",") Col = Split("A,B,C,D,E,F,G,H,I,J,k", ",") For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "8:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "5") Next i End With lige = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Cpt1 = "=IF(c5="""","""",IF(c5=""Name"",""Count"",N(b4)+1))" Cpt2 = "=IF(ISBLANK(b5),"""",SUBTOTAL(3,B$5:B5))" With desWS .Range("B5:B" & lige).Formula = Cpt1: .Range("A5:A" & lige).Formula = Cpt2 .Range("A5:B" & lige).Value = .Range("A5:B" & lige).Value End With End If .AutoFilter End With f.Range("A2:K" & f.Rows.Count).Clear Set a = desWS.Range("A4", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 11 Set a = Union(a, Intersect(a.EntireRow, Columns(r))) Next r a.Copy Destination:=f.Range("a2") End If Application.ScreenUpdating = True End Sub لحفظ الملف بصيغة PDF Sub Save_folder_PDF() Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing sFile = "تقرير النشاط" folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, f.Name) If Msg <> vbYes Then Exit Sub f.Visible = xlSheetVisible With ActiveWorkbook sPath = .path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath f.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub لحفظ التقرير في ملف مستقل Sub Save_folder_Excel() Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim path As String, folderName As String, sMsg As String Dim newWb As Workbook, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Set newWb = ActiveWorkbook newWb.SaveAs FileName:=path & Fname & ".xlsx", FileFormat:=51 newWb.Close WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub فلترة وحفظ PDF +EXCEL.xlsm

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

السلام عليكم جرب هذا التعديل Private Sub TextBox2_Change() If TextBox2 = "" Then AutoFilterMode = False Else Ans = MsgBox("هل انتهيت من الكتابه", vbYesNo) If Ans = vbYes Then Range("H1").AutoFilter , field:=8, Criteria1:=TextBox2.Text Dim X X = Application.Match(Val(TextBox2), ورقة3.Columns(4), 0) If Not IsError(X) Then With ورقة3.Cells(X, "B") .Value = ورقة1.Cells(1, "I").Value .Interior.ColorIndex = 30 'From 1 to 56 لون الخلفيه .Font.ColorIndex = 20 'From 1 to 56 لون الخط End With End If End If End If End Sub

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

أشكرك أستاذ @kkhalifa1960 ، على مشاركة الموضوع ، ولكن ليس هدفي تغيير اي اعدادات في دقة الشاشة ، الفكرة باختصار محاولة لجعل النموذج يفتح بموضع محدد باختلاف الأنظمة والدقة ( دقة الشاشة ) على جهاز المستخدم .

جرب هذا التعديل أخي @ahmed draz ، في زر الإستيراد في نموذج الإستيراد . Private Sub BtnImpotData_Click() If IsNull(listBoxWorksheets) Then MsgBox "لم تقم باختيار ورقة العمل من ملف الاكسل", vbCritical, "" Exit Sub Else Call GetWaiting("انتظر لحظة من فضلك .... يتم معالجة البيانات") Dim sheetRange As String Dim strTable As String Dim strPath As String Dim Check30 As Integer strTable = Me.cmb_TQ_Name.Value strPath = Me.txtPath sheetRange = listBoxWorksheets Check30 = Me.Check30.Value If Check30 = 1 Then DeleteTableSafe strTable End If DoEvents Dim objExc As Object ' late Dim objWbk As Object ' late Dim objWsh As Object ' late 'Set objExc = New Excel.Application ' early Set objExc = CreateObject("Excel.Application") ' late Set objWbk = objExc.workbooks.Open(Me.txtPath) For Each objWsh In objWbk.Worksheets 'Debug.Print objWsh.Name Next DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTable, strPath, True, sheetRange & "$" DoCmd.Close acForm, "frmWaiting" Set objWsh = Nothing objWbk.Close Set objWbk = Nothing objExc.Quit Set objExc = Nothing subFormData.SourceObject = "Table.elemnts 1" subFormData.Visible = True End If End Sub وأخبرني بالنتيجة اداة لإستيراد جداول الإكسل و تصديرها.accdb هذا السؤال موجه لأخ @ahmed draz صاحب الموضوع والتطوير على أداة أستاذنا @ابو الآء

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

تفضل بشمهندس

🙂

اذا مشكلتك اتحلت كما ذكر الأستاذ @عبد اللطيف سلوم ، افتح المشاركه السابقة وراجع التقرير . الجمعية التعاونية.zip

السلام عليكم ورحمة الله وبركاته جزاكم الله خيراً وجعله بميزان حسناتكم آمين ملف رائع بارك الله بجهودكم أخي الكريم عماد غازي

تفضل تم اظافة ورقة خاصة باسم فلترة البيانات وبالاعتماد عليها ستتمكن من فلترة بياناتك بين تاريخين مع ترحيل النتائج الى ملف اكسيل مستقل او او ملف PDF على حسب اختيارك الاكواد الخاصة بهدا الملف تختلف نوعا ما عن الملف السابق ودالك بتنقيحها بشكل مختلف مع اظافة كود خاص بترحيل ملفات PDF وانشاء لكل يوم مجلد مستقل '*****انشاء مجلدات لكل يوم مستقل*** Public Sub Save_folder_PDF() Dim Path$, sFile$, folderName$, fileName$, fileType$ Dim Cpt As String, PDFfile As String Dim lastRow As Long, LastCol As Integer Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("فلترة البيانات"): testDate = Now() fileType = "تقارير": folderName = "ملفات PDF": sFile = UCase(Format(testDate, "h\hmm")) & " " & "تقرير النشاط" Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, ": تأكيد ") If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible If WorksheetFunction.CountA(printing.Cells) = 0 Then MsgBox " ! لا توجد بيانات للحفظ", vbOKOnly + vbInformation Exit Sub End If LastCol = WS.Rows(2).Find("*", WS.Cells(2, WS.Columns.Count), , , , 2).column lastRow = WS.Columns(1).Find("*", WS.Cells(WS.Rows.Count, 1), , , , 2).Row ' Path = "C:" '" قم بتحديد مسار حفظ الملفات على حسب احتياجاتك ' المسار الافتراضي للملف الرئيسي Path = Application.ActiveWorkbook.Path If Right(Path, 1) <> "\" Then Path = Path & "\" Cpt = Path & folderName & "\" If Dir(Cpt, vbDirectory) = vbNullString Then MkDir Cpt Cpt = Cpt & UCase(Format(Date, "yyyy-mm-dd")) & " " & fileType & "\" If Dir(Cpt, vbDirectory) = vbNullString Then MkDir Cpt PDFfile = Cpt & sFile & ".pdf" WS.PageSetup.PrintArea = _ WS.Range("A2", WS.Cells(lastRow, LastCol)).Address WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=PDFfile, _ Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "": WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbInformation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Save_As_PDF() 'انشاء مجلد في نفس مسار الملف Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("فلترة البيانات") Dim F As Worksheet: Set F = printing sFile = "تقرير النشاط": folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, F.Name) If Msg <> vbYes Then Exit Sub F.Visible = xlSheetVisible LastCol = F.Rows(2).Find("*", F.Cells(2, F.Columns.Count), , , , 2).column lastRow = F.Columns(1).Find("*", F.Cells(F.Rows.Count, 1), , , , 2).Row With ActiveWorkbook sPath = .Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath F.PageSetup.PrintArea = _ F.Range("A2", F.Cells(lastRow, LastCol)).Address F.ExportAsFixedFormat Type:=xlTypePDF, _ fileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False F.PageSetup.PrintArea = "" F.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub بالنسبة لكود الفلترة وانشاء ملف Excel مستقل ستجده داخل الملف المرفق بالتوفيق ............ فلترة وحفظ الملفات V2.xlsm

الزاويا اليمين اسفل

تفضل استاذنا

استاذ @Foksh قد يفيدك هذا الموضوع لاستاذنا @jjafferr .

حسب تجارب الاخوة السابقين يستوعب مئات الآلاف

فى ظل امكاناتي المتواضعه وللحاجه وبعد مراجعة العديد من الحلول المتوفره على الويب التى لم اجد بها ضالتي اقدم لكم مربع التلوين هذا colorpicker حيث يقوم بتلوين خلفية النموذج بشرط تسميتها detail بالانجليزيه ورأس النموذج بشرط تسميته header وتذييل النموذج بشرط تسميته footer وكذلك مربعات التنسيق والتجميل rectangle بشرط ان يتم تسميتها box1 , box2 وهكذا وضعت وظائف التلوين فى حدث عند النقر المزدوج فى كل منها طبعا يمكن استخدام اسماء عناصر عربيه لكنها ستحتاج تعديل فى الجدول والكود ولا افضل ذلك المربعات الونيه يمكن تلوين حتى box9 اى تسع مربعات النموذج يحتوي اكثر من 400 لون معد سلفا منها 160 لون عشوائي تتغير بضغطة زر الى اخرى كل لون تختاره يمكنك التعديل عليه بتغيير قيم الالوان الاحمر والاخضر والازرق يوجد جزء خاص لضبط الخطوة فى + او - بقيم من 1 حتى 25 كما يوجد جزء خاص بتحديد سلوك تلوين الفورم فى المره القادمه التى سيفتح فيها وامامك 3 خيارات اما استخدام خياراتك الاخيرة للالوان واما استخدام الوان الجدول الافتراضيه وهى الوان رماديه يمكن تغييرها من الجدول فقط واما استعادة الوان الفورم عندما تم تصميمه ويتم التحكم فى كل جزء على حده اعلم انه بدائي لكنه يؤدي الغرض بفاعليه ونرحب بالافكار الجديده الكود متاح للجميع استخدامه شخصيا او تجاريا بشرط عدم ازاله شعار مؤسسة وعد الخيريه او كود الصوره اتمنى تزويدي بتعليقاتكم البرمجيه لتحسي الكود وتطويره لتعيين الصور كخلفيات يمكن التحميل من هنا mycolorpiker.zip

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

السلام عليكم و رحمة الله استخدم هذا الكود Sub ReArrange() Dim Arr, Rtb, Tmp Dim WF As Object Dim x As Integer, i As Long, p As Long Set WF = WorksheetFunction Arr = Range("B2:C8").Value Rtb = Array("السابعة", "السادسة", "الخامسة", _ "الرابعة", "الثالثة", "الثانية", "الاولى") ReDim Tmp(1 To UBound(Arr, 1), 2) For i = LBound(Rtb) To UBound(Rtb) Tmp(i + 1, 1) = Replace(Arr(i + 1, 2), Arr(i + 1, 2), Rtb(i)) Tmp(i + 1, 0) = WF.Index(Range("B2:C8"), WF.Match(Rtb(i), _ Range("C2:C8"), 0), 1) Next Range("B2").Resize(UBound(Tmp, 1), 2).Value = Tmp End Sub

اعتذر ، تم تعديل المشاركة السابقة والملف المرفق فيها .

تفضل المشروع الجديد 1.zip تم تعديل المرفق ، كنت قد ارفقت الملف الأصلي وليس الملف الذي تم التعديل عليه

عانيت كثيرا فى ايجاد حلول لتوسيط النموذج بوسط الشاشه حتى الذكاء الصناعي اربكني وبعد تجربه العديد من الاكواد والامثله انتبهت اخيرا لان اكسس يقيس الابعاد بالتويبس وويندوز يعتمد البكسل والبكسل حوالي 15 تويبس وهنا تم حل المشكله اليكم مثال بسيط جدا وبموديول واحد لاغير اتمنى ان ينفع احد اخواني ولا يفوتني شكر الجميع فمنكم نتعلم المثال مرفق waadcenterform.accdb

جزاك الله كل الخير والى الأمام والتقدم دائماً . ولي لمسة بسيطة كي ينتفع بها الكل وهي تحريك النموذج بكتابة القيم بــ (Left,Top) بالسنتيمتر . waadcenterform-1.rar

تفضل آمل ان يوافق رغبتك test _tbleeg_UP.rar