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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله تعالى وبركاته اولا واخرا وقبل كل شئ سبحانك لا علم لنا الا ما علمتنا يارب لك الحمد كما ينبغى لجلال وجهك ولعظيم سلطانك الحمد لله الذى هدانا وما كنا لنهتدى لولا أن هدانا الله عزوجل أحبابى واخوانى الكرام أضع بين اياديكم تلك الهدية البسيطة المتواضعة راجيا من الله عزوجل تنال اعجابكم ورضاكم MultiSelectInContinuousForms (V2).mdb

استخدم هذا الكود وسيعمل معك على الإصدارتين #If VBA7 Then Private Type ChooseColor lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr rgbResult As Long lpCustColors As LongPtr flags As Long lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As String End Type #Else Private Type ChooseColor lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As Long flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type #End If Private Const CC_ANYCOLOR = &H100 'Private Const CC_ENABLEHOOK = &H10 'Private Const CC_ENABLETEMPLATE = &H20 'Private Const CC_ENABLETEMPLATEHANDLE = &H40 Private Const CC_FULLOPEN = &H2 Private Const CC_PREVENTFULLOPEN = &H4 Private Const CC_RGBINIT = &H1 'Private Const CC_SHOWHELP = &H8 'Private Const CC_SOLIDCOLOR = &H80 #If VBA7 Then Private Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long #Else Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long #End If Public Function DialogColor(Optional lDefaultColor As Variant) As Long Dim CC As ChooseColor Dim lRetVal As Long Static CustomColors(16) As Long 'Some predefined color, there are 16 slots available for predefined colors 'You don't have to defined any, if you don't want to! CustomColors(0) = RGB(255, 255, 255) 'White CustomColors(1) = RGB(0, 0, 0) 'Black CustomColors(2) = RGB(255, 0, 0) 'Red CustomColors(3) = RGB(0, 255, 0) 'Green CustomColors(4) = RGB(0, 0, 255) 'Blue With CC .lStructSize = LenB(CC) .hwndOwner = Application.hWndAccessApp .flags = CC_ANYCOLOR Or CC_FULLOPEN Or CC_PREVENTFULLOPEN Or CC_RGBINIT If IsNull(lDefaultColor) = False _ And IsMissing(lDefaultColor) = False Then .rgbResult = lDefaultColor 'Set the initial color of the dialog .lpCustColors = VarPtr(CustomColors(0)) End With lRetVal = ChooseColor(CC) If lRetVal = 0 Then 'Cancelled by the user DialogColor = RGB(255, 255, 255) ' White -> 16777215 Else DialogColor = CC.rgbResult End If End Function

السلام عليكم و رحمة الله تعالى و بركاته لقد لفت إنتباهي عند تصفح المنتدى مجموعة أسئلة تدور حول نقل التركيز إلى سجلات نموذج فرعي. و استخدام أكواد طويلة بعض الشيء لحل هذه المشكلة. فقررت أن أكتب هذا الموضوع لأضع الطريقة التي استخدمها فهي قصيرة و سريعة أولا: الانتقال إلى سجل معين حسب ترتيبه نستخدم هذا الكود Me.sub1.SetFocus DoCmd.GoToRecord , , acGoTo, Me.txt2 بحيث sub1 هو اسم النموذج الفرعي و txt2 هو اسم مربع النص الذي نكتب فيه رقم ترتيب السجل أولا: الانتقال إلى سجل معين من خلال البحث عن اسمه نستخدم هذا الكود Me.sub1.SetFocus DoCmd.SearchForRecord , , acFirst, "[first_name]='" & Me.txt & "'" txt هو المربع الذي نستخدمه للبحث الانتقال الى سجل فرعي.accdb

تم وضع الكود اللازم 1- الكود يعطي معاينة قبل الطياعة 2- لجعله يطبع مباشرة استبدل ما موجود في الكود بين علامات اليساوي "============" بــ B.PrintOut Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, Ro%, i% Dim dic As Object Dim Mon_array Dim Itm '++++++++++++++++++++++++++++++++ Sub Fatura_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35 Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then For Each Itm In dic.items() B.Range("E6").Resize(9) = _ Application.Transpose(Split(Itm, "*")) '========================== B.PrintPreview '======================== Next End If Set dic = Nothing End Sub الملف مرفق Bab Salam.xlsm

الف مبروك

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

جرب هذا الملف الماكرو يجد اخر خلية تحتوي الكلمة و يحدد الصف 1- اختر الكلمة التي تريدها من الخلية C1 ثم اضغط الزر الازرق Option Explicit Sub select_row() Dim rg As Range Dim i#, Ro#, Nb# Ro = Cells(Rows.Count, "O").End(3).Row Range("A4:A" & Ro).Rows.Hidden = True For i = Ro To 4 Step -1 If Cells(i, "O") = Range("C1") Then Nb = i Exit For End If Next If Nb > 0 Then Cells(Nb, 1).EntireRow.Hidden = False Range("A" & Nb).Resize(, 25).Select Else Range("A4:A" & Ro).Rows.Hidden = False End If End Sub '+++++++++++++++++ Sub show_rows() ActiveSheet.Cells.Rows.Hidden = False End Sub الملف مرفق Kassim.xlsm

تفضل أستاذ في المثال دالتان معرفتان الدالة الأولى لتفقيط الوقت الدالة الثانية لتفقيط مجموع الوقت دالة تفقيط الوقت.xls

ممكن مرفقك الذي تعمل عليه للتطبيق .....

أكرمك الله وبارك الله فيك

وللتعامل مع الكود استخدم: Me.Text0 = DialogColor(Me.Text0) 'لوضع كود اللون في مربع النص Me.Text0.BackColor = Me.Text0 ' لجعل خلفية مربع النص باللون الذي تم تحديده

شكرا شكرا استاذي الكريم على مجهودك الرائع كل المحبة والاحترام لك جزاك الله خير الجزاء واوسع معرفتك ♥️♥️♥️♥️

ويمكنكم استخدام هذه الدالة أيضا: Function DayPart(inTime As Date) As String Dim timePart As Byte timePart = Fix((CDate(Format(inTime, "hh:mm:ss")) * 24) / 6) Select Case timePart Case 1: DayPart = "صباحا" Case 2: DayPart = "مساءً" Case Else: DayPart = "ليلا" End Select End Function

تم انشاء ماكرو يقوم يهذا العمل (Print_Only _One) 1-اذا كانت الخلية H5 تحتوي على عدد اكبر من المطلوب ( يعني عدد المشتركين او عدد الأسماء) او عدد سالب او صفر او فارغة فأن الماكرو يسجلها 1 وبالتالي يستخرج أول مشترك 2- الماكرو بعمل على عدد المشتركين (مثلاً اذا كتبت 4 في الخلية H5 فإن الماكرو بستحرج رايع مشترك وليس الصف رفم 4) 3- الماكرو القديم ما زال يعمل في حال اردت طباعة الكل دفعة واحدة Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i%, Nb% Dim dic As Object Dim Mon_array Dim Itm Dim rg As Range '++++++++++++++++++ 'Other macro to Ptint One fatura Sub Fatura_Only_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then If Val(B.Range("H5")) <= 0 Or _ Val(B.Range("H5")) > dic.Count Then B.Range("H5") = 1 Else B.Range("H5") = Int(B.Range("H5")) End If Nb = Int(B.Range("H5")) - 1 B.Range("E6").Resize(9) = _ Application.Transpose(Split(dic.Items()(Nb), "*")) Set rg = S.Range("B1:B" & last).Find(B.Range("E7"), lookat:=1) If Not rg Is Nothing Then S.Cells(rg.Row, 1).Resize(, 9).Interior.ColorIndex = 35 End If '========================== B.PrintPreview ' '======================== End If Set dic = Nothing End Sub Bab Salam_New.xlsm

شكرا جزيلا إخوتي على المرور الطيب

مشكور ابا جودي مبدع

انت لم تذكر هذا الشيء في سؤالك ساعمل على ما تريد (ماكرو آخر)

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

استاذ ابا جودي مبدع تسلم

بعد اذن استاذ سليم ولإثراء الموضوع هذا كود أخر Sub FilterRows() Worksheets("Sheet1").Range("A1").AutoFilter Field:=15, Criteria1:="WATE" End Sub ولحذف او اخفاء الفلترة -يمكنك استخدام هذا الكود Sub TurnOFFAutoFilter() Worksheets("Sheet1").AutoFilterMode = False End Sub المصنف1 .xlsm

دائما مبدع ومهندس ومروض اكسس بارك الله فيك وزادك علما

بارك الله بك مبدع اخي الكريم على الكود الجميل

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

اعد رفع المرفق مرة أخرى

للاسف انا والله ما عارف اعمل ى شئ انا اسف جدا جدا ولكن لا تقطع لرجاء من الله ان يسهل لاحد اساتذتنا الكرام الامر ويجرى الحل على يديه ان شاء الله

الحمد لله الذى هدانا وما كنا لنهتدى لولا ان هدانا الله عزوجل طيب اتفضل طلبك جاهز هدية متواضعة : مربع اختيار غير منضم فى نموذج مستمر ☺ - قسم الأكسيس Access - أوفيسنا (officena.net)

الف مبروووك يا أساتذتنا الافاضل

ألف مبروك وإلى الأمام نفع الله بعلمكم وزادكم علماً ورزقكم الصحة ووسع لكم في رزقكم تحياتي

ممكن تجرب المرفق من تنفيذ عمالقة الاوفيس . للإطلاع على المزيد اتوماتيك هايبر لينك.xlsm

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

أولا وقبل أي شئ جزاك الله كل خير ثانياً - الشيت يعمل بشكل رائع في الجمع أما في قيمة أخر معاملة وتاريخها فإنه يأتي بتاريخ النهاية الذي تم اختياره في محددات البحث وقيمة المعاملة في هذا التاريخ والمراد أن يأتي بقيمة وتاريخ أخر معاملة لا تكون صفر للصنف . والتوضيح بالصورة - نتيجة المعادلة ( تظهر تاريخ النهاية كتاريخ أخر معاملة للصنف والكمية الخاصة بتاريخ النهاية تظهرها كأخر قيمة معاملة للصنف ) وهذا ليس المقصود . - النتيجة المراد الحصول عليها هي قيمة وتاريخ أخر معاملة تمت على الصنف ولا تساوي صفر مثل الصورة ثالثاً - كل الأسف لعدم توضيح أن التعامل على شيت الاكسيل يتم من خلال الموبايل وليس الكمبيوتر مما يعني عدم إمكانية إستخدام البرمجيات في شيت الاكسيل . لو أمكن أن يكون الحل بالمعادلات إن تيسر الأمر ولا أريد أن أجهد سيادتكم في ذلك . وفي الختام جزاكم الله كل خير في الدنيا والأخرة .

إليك الدالة المعرفة TimeToLettre الدالة تعمل إلى غاية "99:99:99" وتعمل للساعات فقط أو الدقائق فقط أو الثواني فقط Function TimeToLettre(Time As Variant) As String ' Created By Benkhalifa Djemoui ' Algeria: 05-12-2020 Dim MyHour As Variant Dim MyMinute As Variant Dim MM, HH, SS As String Dim H, M, S As Byte '=============================================================================================================================== MyHour = Array("", "ساعة", "ساعتان") '=============================================================================================================================== MyMinute = Array("صفر", "دقيقة", "دقيقتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع", _ "عشر", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر", _ "عشرون", "واحد و عشرون", "إثنان و عشرون", "ثلاثة و عشرون", "أربعة و عشرون", "خمسة و عشرون", "ستة و عشرون", _ "سبعة و عشرون", "ثمانية و عشرون", "تسعة عشرون", _ "ثلاثون", "واحد و ثلاثون", "إثنان و ثلاثون", "ثلاثة و ثلاثون", "أربعة و ثلاثون", _ "خمسة و ثلاثون", "ستة و ثلاثون", "سبعة و ثلاثون", "ثمانية و ثلاثون", "تسعة و ثلاثون", _ "أربعون", "واحد و أربعون", "إثنان و أربعون", "ثلاثة و أربعون", "أربعة و أربعون", "خمسة و أربعون", "ستة و أربعون", _ "سبعة و أربعون", "ثمانية و أربعون", "تسعة و أربعون", _ "خمسون", "واحد و خمسون", "إثنان و خمسون", "ثلاثة و خمسون", "أربعة و خمسون", _ "خمسة و خمسون", "ستة و خمسون", "سبعة و خمسون", "ثمانية و خمسون", "تسعة و خمسون", _ "ستون", "واحد و ستون", "إثنان و ستون", "ثلاثة و ستون", "أربعة و ستون", _ "خمسة و ستون", "ستة و ستون", "سبعة و ستون", "ثمانية و ستون", "تسعة و ستون", _ "سبعون", "واحد و سبعون", "إثنان و سبعون", "ثلاثة و سبعون", "أربعة و سبعون", _ "خمسة و سبعون", "ستة و سبعون", "سبعة و سبعون", "ثمانية و سبعون", "تسعة و سبعون", _ "ثمانون", "واحد و ثمانون", "إثنان و ثمانون", "ثلاثة و ثمانون", "أربعة و ثمانون", _ "خمسة و ثمانون", "ستة و ثمانون", "سبعة و ثمانون", "ثمانية و ثمانون", "تسعة و ثمانون", _ "تسعون", "واحد و تسعون", "إثنان و تسعون", "ثلاثة و تسعون", "أربعة و تسعون", _ "خمسة و تسعون", "ستة و تسعون", "سبعة و تسعون", "ثمانية و تسعون", "تسعة و تسعون") '=============================================================================================================================== Time = Split(Time, ":") H = Int(Time(0)) M = Int(Time(1)) S = Int(Time(2)) '=============================================================================================================================== If H = 0 Then GoTo Minute Select Case H Case 1 To 2: Select Case M: Case 0: HH = MyHour(H): Case Else: HH = MyHour(H) & " و ": End Select Case 3 To 10: Select Case M: Case 0: HH = MyMinute(H) & " ساعات ": Case Else: HH = MyMinute(H) & " ساعات و": End Select Case 11 To 99: Select Case M: Case 0: HH = MyMinute(H) & " ساعة ": Case Else: HH = MyMinute(H) & " ساعة و ": End Select End Select '=============================================================================================================================== Minute: If M = 0 Then GoTo Second If M <> 15 And M <> 30 Then Select Case M Case 1: Select Case S: Case 0: MM = MyMinute(M): Case Else: MM = MyMinute(M) & " و": End Select Case 2: Select Case S: Case 0: MM = MyMinute(M): Case Else: MM = MyMinute(M) & " و": End Select Case 3 To 10: Select Case S: Case 0: MM = MyMinute(M) & " دقائق ": Case Else: MM = MyMinute(M) & " دقائق و ": End Select Case 11 To 59: Select Case S: Case 0: MM = MyMinute(M) & " دقيقة ": Case Else: MM = MyMinute(M) & " دقيقة و ": End Select End Select '=============================================================================================================================== Else If H <> 0 Then Select Case M Case 15: Select Case S: Case 0: MM = " ربع ": Case Else: MM = " ربع و ": End Select Case 30: Select Case S: Case 0: MM = " نصف ": Case Else: MM = " نصف و ": End Select End Select Else Select Case M Case 15: Select Case S: Case 0: MM = " ربع ساعة ": Case Else: MM = " ربع و ": End Select Case 30: Select Case S: Case 0: MM = " نصف ساعة ": Case Else: MM = " نصف و ": End Select End Select End If End If '=============================================================================================================================== Second: If H <> 0 Or M <> 0 Then Select Case S Case 1: Select Case M: Case 0: SS = " و ثانية": Case Else: SS = " ثانية": End Select Case 2: Select Case M: Case 0: SS = " و ثانيتان": Case Else: SS = " ثانيتان": End Select Case 3 To 10: Select Case M: Case 0: SS = " و " & MyMinute(S) & " ثوان": Case Else: SS = MyMinute(S) & " ثوان": End Select Case 11 To 59: Select Case M: Case 0: SS = " و " & MyMinute(S) & " ثانية": Case Else: SS = MyMinute(S) & " ثانية": End Select End Select '=============================================================================================================================== Else Select Case S Case 1: SS = "ثانية" Case 2: SS = "ثانيتان" Case 3 To 10: SS = MyMinute(S) & " ثوان" Case 4 To 59: SS = MyMinute(S) & " ثانية" End Select End If '=============================================================================================================================== TimeToLettre = Trim(HH) & " " & Trim(MM) & " " & Trim(SS) '=============================================================================================================================== Erase MyHour, MyMinute End Function

الكود من المنتدى لاستاذنا عبدالله باقشير ملف2.xlsb

الاساتذة الافاضل Ali Mohamed Ali حسين مامون ابو يحيى1 سليم حاصبيا ابراهيم الحداد abouelhassan محمد حسن المحمد yara ahmed محمد يوسف فوزى فوزى ashraf_abdalla ابو طيبه بارك الله في الجميع واشكركم جميعا على هذه الثقة وادعو الله ان اكو ن في مستوى المسئولية حفظكم الله جميعا

استاذي اطلع على هذا الرابط اعتقد تجد فيه طلبك لما اتاكد منه لأننا حاليا على الموبيل http://www.arabteam2000-forum.com/index.php?showtopic=145213

تم معالجة الامر سند فبض.xlsx

اخى الفاضل قم بالضغط كليك يمين فى الخلية B7 ثم اختيار format cell ثم اختيار التنسيق date من الشاشة التى ستظهر من على اليسار ثم ok

بعد اذن الاخ الصديق ياسر تطوير بسيط للكود بحيث انه بالاضافة الى ادراج اسماء الصفحات، الوصول الى الصفحة المعنية بالضغط على اسمها(HyperLink) فهرسة الصفحات.rar

أخي العزيز تفضل طلبك بالمرفق تحياتي قائمة منسدلة تظهرعمودين رد.rar