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

السلام عليكم ورحمة الله وبركاته واضح انك نسيت تحيه الاسلام يا اخى عمر تفضل اخى الكريم Sub test() Dim WB As Workbook, WS As Worksheet, SH As Worksheet, LR As Long Set SH = ThisWorkbook.Worksheets("فاتورة") Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "القيمة_المضافة.xlsm", False) For Each WS In WB.Worksheets If SH.Range("J1") = WS.Name Then LR = Application.Max(5, WS.Cells(Rows.Count, 1).End(xlUp).Row) + 1 WS.Range("A" & LR).Value = LR - 5 WS.Range("B" & LR) = SH.Range("H27") WS.Range("C" & LR) = SH.Range("H23") WS.Range("D" & LR) = SH.Range("H25") WS.Range("E" & LR) = SH.Range("H26") WS.Range("F" & LR) = SH.Range("H3") WS.Range("G" & LR) = SH.Range("B7") WS.Range("H" & LR) = SH.Range("F5") WS.Range("H6:H" & LR).NumberFormat = "[$-1010000]yyyy/mm/dd;@" GoTo 86 End If Next WS 86 WB.Close Savechanges:=True End Sub يرجي تعديل عنوان الموضوع لاسم مناسب للموضوع ليسهل في عمليه البحث للاعضاء

تفضل ضع هذا الكود في حدث الحالي Dim ctl As Control For Each ctl In Me.Controls If TypeName(ctl) = "TextBox" Then If IsNull(ctl) Or ctl = "" Then Form.Controls(ctl.Name).Visible = False End If End If Next ctl

أسهل طريقة لإخفاء شعار الأكسس وإظهار شعارك الخاص على البرنامج وبدون أكواد هو كتابة اسم الأيقونة بهذه الطريقة .. وتكون دائما بجانب ملف الأكسس : وبالتعليم على خيار (الاستخدام كأيقونة نموذج وتقرير ) ستظهر لك حتى على نوافذ النمانج والتقارير ..

لسه والقادم اجمل ...ده لسه فيه ...... بلاش احرق لكم المفاجآت

ما شاء الله علي حضرتك كلها حلات فوق الممتازة جزاك الله عنا كل خير

تفضل s.zip

19- عرض الرسالة مع زر أمر او Command Buttons ومعه ملاحظة مع زر غير مفعل . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 19 - Msgbox With Command Button With Note & Disable Button.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

18- عرض الرسالة مع زر أمر او Command Buttons ومعه ملاحظة . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 18 - Msgbox With Command Button With Note.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

17- عرض الرسالة مع زر أمر او Command Buttons . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 17 - Msgbox With Command Button.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

16- عرض الرسالة مع ازرار مخصصة بمسميات مخصصة . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 16 - Customize Buttons.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني . 16 - Customize Buttons.accdb

15- عرض الرسالة مع جميع الازرار المتاحة بداخل الكلاس . صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 15 - All internal Buttons.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

الحمد لله انها بالفعل مكتبه رائعة وسهله الاستخدام وأتمنى أن تكون ذات نفع معك وشكرا على مرورك الكريم الي جي فعلا هيكون اقوي أن شاء الله والجميل في الأمر أنها ستغنيك عن إنشاء نماذج اضافيه لأجل اختيار أمر أو تحديد شئ فيستبدل برساله بها كل المرغوب والمطلوب لك تحياتي @ابو جودي

اخى الكريم عمر هذا طلب اخر غير الذي في المشاركه الاولى اكتب موضوع جديد بالطلب الجديد على فكرة المنتدي مش هيدفعك فلوس على الموضوع الجديد 🤗😁

آمين يارب العالمين وإياكم وجزاكم مثله اخى الكريم

تفضل هذا التعديل النقر المزدوج على حقل الكود لعرض القائمة ورشة 1 - Copy.zip

اخوي افتح سؤال جديد و ارفق فيه مثال لكي يتم التعديل عليه شكرا لك

وعليكم السلام ورحمه الله وبركاته تفضل اخى الكريم Sub Test() Dim WB As Workbook, WS As Worksheet, SH As Worksheet, Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Set SH = ThisWorkbook.Worksheets("ترحيل يومية") Arr = SH.Range("A5:F" & SH.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "العملاء.xlsm", False) For Each WS In WB.Worksheets If SH.Range("D2") = WS.Name Then For i = 1 To UBound(Arr, 1) p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next Next End If If p > 0 Then WS.Range("H" & WS.Cells(Rows.Count, 8).End(xlUp).Row + 1).Resize(p, UBound(Temp, 2)).Value = Temp WS.Range("K7:K" & WS.Cells(Rows.Count, 8).End(xlUp).Row).NumberFormat = "[$-1010000]yyyy/mm/dd;@" GoTo 86 End If Next WS 86 WB.Close Savechanges:=True End Sub

تفضل اخى الكريم 1- اجعل الملف الذي اسمه real data.xlsx بجوار الملف الذي اسمه (Total.xlsx ) الكود سوف يحذفه ووضع مكانه ملف باسم (Total.xlsb ) 2- انسخ الكود التالي 3- اربط الزر قي صفحة ( total ) بالكود الذي اسمه ( total ) 4- ثم اضغط على الزر 5- سوف يعمل الكود ويجلب البيانات الموجوده في جميع الشيتات ماعدا ٣ شيتات معينة وهما ( summery ) (Hold ) (Time ) Sub Total() Dim WS As Worksheet, WB As Workbook, SH As Worksheet Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Set SH = ThisWorkbook.Worksheets("Total") Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "real data.xlsx", False) For Each WS In WB.Worksheets If WS.Name <> "Total" And WS.Name <> "SUMMARY" And WS.Name <> "TIME" And WS.Name <> "HOLD" Then WS.Range("A6:S" & WS.Cells(Rows.Count, 2).End(xlUp).Row).Copy _ SH.Range("A" & SH.Cells(Rows.Count, 2).End(xlUp).Row + 1) End If Next WS WB.Close Savechanges:=True SH.Columns.AutoFit ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Total", FileFormat:=xlExcel12 On Error Resume Next Kill ThisWorkbook.Path & "\" & "Total.xlsx" On Error GoTo 0 Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True End Sub

انا وياك اخى الكريم اسعندنى مرورك الكريم تقبل تحياتي .

اتفضل بسيطة غير للكود الاتى On Error GoTo Oops Dim db As dao.Database: Set db = CurrentDb() Dim rs As dao.Recordset: Set rs = db.OpenRecordset("file-1") Dim intSpID As Long: intSpID = 0 With rs .MoveFirst Do intSpID = intSpID + 1 rs.Edit rs![الرقم الحسابي] = 11 & intSpID rs.Update .MoveNext Loop Until .EOF .Close End With db.Close function_exit: Set rs = Nothing Set db = Nothing Exit Sub Oops: ' Handle the errors here GoTo function_exit

السلام عليكم ورحمة الله وبركاته على حسب فهمى لسؤالك بعد اذن الاستاذ حسين عدل هذا السطر Sheets("P.R.T").PrintOut Copies:=x, Collate:=True, _ IgnorePrintAreas:=False الى هذا السطر Sheets("P.R.T").PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=False

بالنسبه لتغيير التاريخ فهو المطلوب .. لكن يقوم بطباعه شيك واحد بالتاريخ الاول وشيكين للتاريخ الثاني وثلاثه للتاريخ الثالث وهكذا ... اريد نسخه واحده فقط لكل تاريخ اعتقد ان الخطا مني فالمقصود بعدد النسخ المكتوبه في الخليه D3 هو عدد تسلسل التواريخ مثلا عند كتابه 2 يطبع شهرين وعند كتابه 12 يقوم بطباعه شيكات سنه كامله اي 12 شيك وشكرا لتفاعلك ومجهودرك واعتذر لانني انشغلت قليلا

متابع 🙂

Private Sub ComboBox1_Change() Const iCols As Integer = 11 Dim a(1 To 1000, 1 To iCols), b(), rng As Range, c As Range, i As Long, ii As Long With Sheets(1) Set rng = .Range("B3:M" & .Cells(Rows.Count, "B").End(xlUp).Row) rng.AutoFilter Field:=12, Criteria1:=ComboBox1.Value On Error Resume Next Set rng = .Range("B3").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If Not rng Is Nothing Then For Each c In rng i = i + 1 For ii = LBound(a, 2) To UBound(a, 2) a(i, ii) = c.Offset(, ii - 1).Value Next ii Next c b = Application.Transpose(a) i = Application.Min(UBound(a, 1), i) ReDim Preserve b(1 To iCols, 1 To i) b = Application.Transpose(b) ListBox1.List = b End If End Sub

يمكن وضع الرقم الثاني في h4 واستعمال هذه المعادلة =SUMIF($C:$C,G4,$D:$D)+SUMIF($C:$C,H4,$D:$D) أو هذه =SUMPRODUCT(SUMIF(C:C, G4:H4, D:D)) بالتوفيق

السلام عليكم 🙂 لتعم الفائدة ، رجاء قراءة الطريقة السابقة ، والتي يمكن قراءتها من هنا : https://www.officena.net/ib/topic/107637-اجعل-برنامجك-يعمل-على-النواتين-32بت-و-64بت/ ------------------------------------------------------------------------------------------------------------------ اذا عملنا برنامج على الاكسس 32بت ، وفيه مكتبات الوندوز الـ 32بت (لاحظ الرقم 32 في اسم المكتبة: comdlg32.dll) ، ثم شغلنا البرنامج على اكسس 64بت ، فنحصل على هذا الخطأ : . للعمل بهذه الطريقة محتاجين الى: 1. ملف في موقع مايكروسوف (مرفق نسخة Win32API_PtrSafe.zip) ، وفيه طريقة عمل مناداة النواتين : https://www.microsoft.com/en-us/download/details.aspx?id=9970 وعند فك الملف ، سنستعين بالملف Win32API_PtrSafe.TXT ، 2. البرنامج Notepad++ المجاني ، ويمكن انزاله من هنا : https://notepad-plus-plus.org بعد تنصيب البرنامج ++Notepad ، يمكننا فتح الملف Win32API_PtrSafe.TXT به : هذا البرنامج يفهم تنسيق وعمل الكثير من لغات البرمجة ، ومنها VB ، ونستفيد منه حتى في برمجة كود VBE لأنه يفهم تنسيقها: . ------------------------------------------------------------------------------------------------------------------ سنستخدم المرفق في هذ الرابط لنجعله يعمل على النواتين 32بت و 64بت: https://www.officena.net/ib/topic/61106-هدية-من-اليمين-الى-اليسار،-مربع-القائمة-listbox-والشجرة-treeview/ هذه هي مكتبات 32بت الوندوز المستعمله في المرفق: Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public 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 Public Declare Function GetFocus Lib "user32" () As Long Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long . خطوات العمل: A. ننسخ اسم المكتبة GetWindowLong من برنامج الاكسس ، B. ثم في برنامج ++Notepad ، نبحث عن هذه الكلمة عن طريق Ctrl+F ، C. فنضع الكلمة مكان البحث ، وننقر على المربع: Find All in Current Document . D. نرى هذ النافذة تُفتح في اسفل البرنامج ، اهم شيء في هذه النافذه هو ان نفرق بين كلمة البحث التي نريدها ، ونفرقها عن كلمات البحث المشابهه والتي لا علاقة لنا بها (يجب ملاحظة ان بعض البرامج/الامثلة التي ننزلها من الانترنت ، يكون صاحبها عمل تغيير في اسم المكتبة ، مثلا: بدل GetWindowLong يكون apiGetWindowLong ، فيجب ان نعرف انه نفس الاسم ، ونبحث عن الكلمة الاصل ، كما نلاحظ ان تعديل الاسم يتم من بدايته وليس من نهايته) . E. اذن نرى هنا ان آخر سطرين فيهما طلبنا ، F. ندقق في السطر ، ونبحث عن اي كلمة تنتهي بـ Ptr ، مثل LongPtr ، CLngPtr ، VarPtr ، ObjPtr ، StrPtr ، او الكلمات التالية LongLong ، CLngLng ، فاذا وجدناها ، اذن يجب التصريح لهذه المكتبة في الكود في برنامجنا على سطرين مختلفين ، السطر الاول للنواة 64 بت ، ونأخذه من برنرنامج ++Notepad ، والسطر الثاني للنواة 32 بت ، ونأخذه من برنامجنا الاصل ، هكذا : #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long #End If . *** الخطوة الاولى والاهم هي اضافة كلمة PtrSafe بعد كلمة Declare ، للنواة 64بت. *** لاحظ اننا اضفنا كلمة Public في اول السطر للنواتين ، *** وبعد كل خطوة نعملها ، يجب ان نعمل Compile :على الاكسس 32 بت والاكسس 64 بت :حتى نتأكد انه لا توجد اخطاء ونتبع نفس الخطوات اعلاه لبقية المكتبات ، المكتبة التاليه: SetWindowLong ، والنتيجة نفسها مثل المكتبة السابقة ، اذن الكود اصبح #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long #End If . وهكذا مع بقية المكتبات ، فيكون الكود النهائي: #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function InvalidateRect Lib "user32" Alias "InvalidateRect" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Public 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 Public Declare PtrSafe Function GetFocus Lib "user32" Alias "GetFocus" () As LongPtr Public Declare PtrSafe Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public 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 Public Declare Function GetFocus Lib "user32" () As Long Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long #End If . الآن لنفترض ان لدينا هذه المكتبة كذلك: Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) . نلاحظ في البحث انه لا توجد لدينا اي من كلمات التي ذكرناها في #F اعلاه . اذن نكتب السطر (من برنامجنا ذو 32 بت) نفسه مرتين ، مرة للنواة 64 بت ، ومرة للنواة 32 بت ، فيصبح الكود (الفرق بين السطرين هي كلمة PtrSafe) : #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #Else '32 bits Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #End If او #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #Else '32 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #End If او سطر واحد مستقلا Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) ------------------------------------------------------------------------------------------------------------------ 2021-11-20 : اخوي @عبدالله المجرب نبهني عند استخدام الاكسس 64بت ، يظهور خطأ في مرفق الرابط: https://www.officena.net/ib/topic/64989-هدية-برنامج-تصدير-بيانات-من-جداولاستعلامات-اكسس-الى-اكسل-،-32بت-و-64بت/ لما نعمل Compile للبرنامج على كمبيوتر به اكسس 64بت ، تظهر هذه الرسالة ، واللي معناها مافي توافق في تعريف المتغير (يعني جزء من سطر الكود تم تعريفه بطريقة ، وجزء آخر من سطر الكود تم تعريفه بطريقة لا تتلائم مع المتغير السابق ، وابسط مثال: متغير تم تعريفه كنص ، ثم تعطي قيمته الى متغير آخر تم تعريفه كرقم) : . من الملاحظة ، نرى انه بما اننا نستخدم اكسس 64بت ، فتعريف المكتبة ShellExecute يكون عن طريق (VB7) ، وتعريفها انها LongPtr ، بينما في الكود ، اعطينا قيمة ShellExecute الى المتغير lRet والذي تم تعريفه على انه Long ، لهذا السبب لا يوجد توافق بين المتغيرين ، وعليه نحصل على الخطأ !! هناك حلين للموضوع: إما ان نعمل if VBA7 then# خاص للمتغير lRet لحالتي 32بت و 64بت ، او نحذف تعريف المتغير lRet من الكود ، ونضعه في الاعلى ، مع تعريف المكتبة ShellExecute ، وهذا ما قمت به: . وبعد عمل Comiple مرة اخرى ، نحصل على خطأ مشابه للخطأ اعلاه ، ولكن لمكتبة اخرى : . والحل ، كما عملته للمشكلة السابقة ، فيصبح الكود : . وبعد عمل Compile مرة اخرى ، نجد ان الكود يعمل بدون اخطاء 🙂 ------------------------------------------------------------------------------------------------------------------ 2021-11-23: اخوي @ابا جودى طلب مساعدة في برنامجه ، ليعمل على النواتين: https://www.officena.net/ib/topic/111963-سؤال-بخصوص-التعديل-على-قاعدة-بيانات-لتعمل-على-32-64-bit/ والشيء الجديد فيه والذي لم يتم شرحه سابقا هو: المتغير hIcon (باللون الاصفر) ، تعريفه يعتمد على النواة : . وعندنا هذه الدالة fSetIcon ومعرفها Long ، وفي الدالة ، نعطي نتيجة hIcon الى fSetIcon . المشكلة لما نواة البرنامج تكون 64بت ، فحينها يكون معرف الحقل hIcon هو LongPtr ، بينما الدالة fSetIcon لا يزال معرفها Long ، وهنا نحصل على رسالة خطأ بعدم تطابق معرف الحقلين !! والطريقة التي استعملتها هي: استعمال الدالة مرتين ، مرة بمعرف LongPtr اذا كانت النواة 64بت ، ومرة بمعرف Long اذا لم تكن النواة 64بت : . وعلشان نعرف ان البرنامج تقبل هذا التغيير ، يجب ان نعمل Compile 🙂 جعفر Win32API_PtrSafe (2).zip

تفضل التعديل Database1.accdb

اخوي ابا جودي 🙂 ملاحظتك غير دقيقة !! لأنه اذا استعملت الكود حقك في نظام وندوز مافيه عربي ، فستحصل على هذه الرسالة ، لأن الكود عندك به كلمات عربية : والطريقة اللي ممكن تجعل برامجك تشتغل بكل اللغات بدون الخطأ اعلاه : ولكن ، صحيح انك ما راح تحصل على خطأ ، وصحيح انك استخرجت الارقام العربية من unicode الخط ، ولكن كلماتك العربية (اسماء الايام والاشهر) تحتاج ان يكون في الوندوز خطوط عربية 😞 جعفر

السلام عليكم ورحمة الله وبركاته.. قمت بتجربة ادراج مربع نص في نموذج ثم قمت بتنسقه yyyy/mm/dd بعد ذلك من تبويب تصميم اخترت محاذاة النص جهة اليمين ( بجوار لون الخط وحجمه .... ) ومن ورقة الخصائص ومن تنسيق اخترت محاذاة النص عامة اتمنى الأساتذه الكرام التجربه وافادتنا جميعا.. وفقنا الله واياكم