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

السلام عليكم ورحمة الله ربما تقصد هذا الشكل id 2.xlsm

يمكن اختصار الكود لكل زر على النحو التالي (مثال على الزر رقم 1) Dim sh As Worksheet, lrow As Long Private Sub CommandButton1_Click() Application.EnableEvents = False If TextBox1.Value <> "" And _ TextBox2.Value <> "" And TextBox3 <> "" _ And TextBox4.Value <> "" _ And TextBox5.Value <> "" Then Set sh = ActiveSheet Dim i With sh lrow = .Range("B" & Rows.Count).End(xlUp).Row With .Range("B" & lrow + 1) For i = 1 To 5 .Offset(, i - 1) = _ Me.Controls("TextBox" & i).Value Me.Controls("TextBox" & i).Value = "" Next End With End With Else MsgBox ("InComplete data") End If Application.EnableEvents = True End Sub

جرب هذا لعله المطلوب ترحيل (1).xlsm

شكر وتقدير واحترم من اخيك استاذ عبد الفتاح

تفضل لا تنسى تغيير مسار الملف على حسب مكان التخزين Sub Test() Dim sr As Workbook Set sr = Workbooks.Open("C:\Users\alhagag\Downloads\touati\touati1.xlsx", True, True) ThisWorkbook.Activate Worksheets("sheet1").Range("B2:E200").Value = sr.Worksheets("sheet1").Range("a2:d200").Value sr.Close End Sub touati.rar

On Error GoTo Error_ErrorZ If Len(Me.B1 & vbNullString) = 0 Or Len(Me.B2 & vbNullString) = 0 Or Len(Me.B3 & vbNullString) = 0 Or Len(Me.B4 & vbNullString) = 0 Or Len(Me.B5 & vbNullString) = 0 Then Else DoCmd.SetWarnings False DoCmd.OpenQuery "Query1" DoCmd.SetWarnings True ' MsgBox "Done", vbInformation DoCmd.RunCommand acCmdRefresh End If Error_ErrorZ: MsgBox "Not Done", vbInformation

اشكرك اخي ابو تراب جربت هذا الحل بالفعل ولكن المشكلة في تغيير الرسالة فجربت وضع الرسالة عند الخطأ للنموذج ولكنها مش عجبني حبيبي يا غالي استاذ احمد شعلة المنتدي هجرب وارد عليك 🌹😍💓

وعليكم السلام اخى واستاذى @محمد سلامة مشاركه لاخى واستاذى @ابو تراب جزاه الله خيرا ومنورين الموقع اساتذتى 💐 ارفق لك مثال لاختنا زهره جزاها الله خيرا Private Sub Rn_AfterUpdate() If DLookup("[رقم الملف]", "[الحضور]", "[رقم الملف]=" & Me![Rn] & " AND [التاريخ] =#" & Date & "#") Then MsgBox "معذرة اخي الكريم .... هذا الرقم سبق ادخاله من قبل", vbCritical, "تنبيه" DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70 DoCmd.Close Else DoCmd.Requery "الاسم1" DoCmd.Requery "الوظيفة1" DoCmd.RunCommand acCmdSaveRecord End If End Sub ارجو ان يفى بالغرض معك استاذى بالتوفيق za-عدم تكرار الرقم-END.rar

وعليكم السلام ممكن عمل مفتاح يتكون من رقم الفاتورة و التاريخ

جزاكما الله خيراً أخويّ الكريمين علي محمد علي وأحمد يوسف على التفاعل البناء في المنتدى الكريم

ayman42001 أين الضغط على الإعجاب لهذه الإجابة الممتازة ؟!!!!💙

أرجو أن يكون هو المطلوب ، وبما أنك جديد في المنتدى - أخي الكريم - يرجى مراعاة القوانين التي سنها المنتدى لمنع تكرار الكثير من المشاركات دون فعالية تحويل الارقام لحروف عربي.xls

وجزاكم بمثل ما ذكرتم أخي الكريم @Ali Mohamed Aliوأنا بدوري اعتبرتها أحسن إجابة كرماً منك إذا أنت أكرمت الكريم ملكته وإن أنت أكرمت اللئيم تمردا تقبل تحياتي العطرة.

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

تم التعديل على البرنامج كونه تالف تقريباً برنامج المخازن.xlsm

جزاك الله خيرا استاذى الفاضل فكرة ممتازة الف شكر على تعاونكم معنا 😍🌹

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

في مربع التحرير الموجود في التقرير افتح على الخصائص : لسان التبويب بيانات ثم غير في الخاصية : عمود منضم من الرقم 1 الى الرقم 2

بوركت يا بطل الرائد77 جزاك الله خيرا واثقل بها ميزان حسناتك

touati.xlsm

اشكرك استاذ أحمد الفلاحجى تحياتي

لقد قمت بالتعديل على الملف واعادة رفعه يمكنك الاطلاع عليه بالتوفيق

بعد اذن الأخ أمين هذا الملف adelalmalki.xlsm

تفضل لا تنسنى بصالح الدعاء المصنف2 .xlsm

شكر وتقدير واحترام استاذنا

انظر هذا بعد التعديل ؟؟؟؟؟

السلام عليكم بعد اذن استاذي واخي @أحمد الفلاحجى هذا برنامج بسيط لحساب تاريخ استحقاق العلاوة السنوية بصورة تلقائية مع تنبيه بالوميض المتقطع بالالوان. وهو يعمل كالتالي: 1- ادخل تاريخ استحقاق اخر علاوة وهو يحسب الباقي لمدة سنه 2- عند وجود كتب شكر وتقدير للموظف يقوم البرنامج بعد اختيار عدد كتب الشكر والتقدير بتقديم تاريخ العلاوة لمده شهر او شهرين او ثلاثة كحد اقصى لمنح القدم حسب علمي. 3- عند اقتراب موعد استحقاق العلاوة ولمدة 5 ايام قبل تاريخ الاستحقاق يظهر وميض احمر متقطع للتنبيه 4- عند تساوي تاريخ الاستحقاق مع تاريخ اليوم (يجب ان يكون تاريخ جهاز الحاسوب مضبوط) يظهر الوميض المتقطع بلون ازرق. 5- عند انتهاء فترة الاستحقاق ولمده خمسة ايام يظهر الوميض بلون اخضر دلاله على انتهاء الاستحقاق. ملاحظه : يمكن عمل اضافات للبرنامج للخدمة الوظيفية (جمع الخدمة الكلية من تاريخ او مباشرة باليوم والشهر والسنه) او تاريخ استحقاق التقاعد لعمر 60 سنة تحياتي العلاوات.rar

بارك الله بكم أخي الكريم

لا حاجة للتسلسل الرقمي للبيانات لأن اكسل يدرجها اوتوماتيكياً الكود Option Explicit Sub tRANSfERE_DATA() Dim M As Worksheet, D As Worksheet Dim Arr_D, Arr_H, Lr_D As Long Dim rg As Range Set M = Sheets("main"): Set D = Sheets("data") Set rg = D.Range("B3", Range("B2").End(4)) Lr_D = rg.Rows.Count If Lr_D > 10000 Then Lr_D = 3 Else Lr_D = D.Range("B3").Offset(Lr_D).Row End If Arr_D = Application.Transpose(M.Range("D3:D6")) Arr_H = Application.Transpose(M.Range("H3:H12")) D.Cells(Lr_D, 2) = Lr_D - 2 D.Cells(Lr_D, 3).Resize(, UBound(Arr_D)) = Arr_D D.Cells(Lr_D, "G").Resize(, UBound(Arr_H)) = Arr_H End Sub الملف مرفق Commandos.xlsm

برنامج رائع أستاذى / @محمد صالح

جرب هذا الكود الصفحة Repport من هذا الملف Option Explicit Sub get_From_To() If ActiveSheet.Name <> "Repport" Then Exit Sub Dim Sw As Worksheet, R As Worksheet Dim Mmin As Byte, Mmax As Byte, i As Byte, S# Dim x%, m%, col As Byte, y As Byte, t As Byte Dim My_ro%, k% Dim Bol As Boolean Set R = Sheets("Repport") If Val(R.Range("D2")) = 0 Or Val(R.Range("E2")) = 0 Then R.Range("D2") = 1: R.Range("E2") = 12 End If Mmin = Application.Min(R.Range("D2:E2")) Mmax = Application.Max(R.Range("D2:E2")) R.Range("D4").CurrentRegion.ClearContents m = 4 For i = 1 To (Mmax - Mmin + 1) R.Cells(4, m) = Mmin + i - 1 m = m + 1 Next t = R.Cells(Rows.Count, 2).End(3).Row col = R.Cells(4, 1).Resize(, m - 1).Columns.Count For x = 5 To t For y = 4 To col Set Sw = Sheets(R.Cells(4, y) & "") If Not Bol Then My_ro = Sw.Range("B:B"). _ Find(R.Cells(x, 2), Lookat:=1).Row Bol = Not Bol End If For k = 5 To 26 Step 3 S = S + Val(Sw.Cells(My_ro, k)) Next k R.Cells(x, y) = S: S = 0 Next y Bol = Not Bol Next x R.Cells(4, y) = "SUM" For x = 5 To t R.Cells(x, col + 1) = _ Application.Sum(R.Cells(x, 4).Resize(, col)) Next R.Cells(t + 1, col + 1) = _ Application.Sum(R.Cells(4, col + 1).Resize(t)) R.Cells(t + 1, 2).Resize(, col). _ Interior.ColorIndex = xlNone R.Cells(t + 1, col + 1). _ Interior.ColorIndex = 6 End Sub File Included MaKhazin_1.xlsm

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

جرب هذا الملف Fuction_split_name.xlsm

Sub Export_Specific_Sheets_To_One_Workbook_Using_Arrays() Dim ws As Worksheet Dim sSheets() As String Dim n As Long Application.ScreenUpdating = False For Each ws In Worksheets(Array("انسولين الهيئة", "انسولين الطلاب والرضع", "تقارير الاصناف")) n = n + 1 ReDim Preserve sSheets(1 To n) sSheets(n) = ws.Name Next ws Worksheets(sSheets).Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Output", FileFormat:=51 Application.DisplayAlerts = True ' ' For Each ws In ActiveWorkbook.Worksheets ' ws.UsedRange.Value = ws.UsedRange.Value ' Next ws For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws ActiveWorkbook.Close True Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub تم تعديلالكود بواسطة الاستاذ ياسر خليل جزاه الله خيرا وتم المطلوب والحمد لله وهذا الجزء هو ماتم تعديله For Each ws In ActiveWorkbook.Worksheets ws.Unprotect 123 ws.UsedRange.Value = ws.UsedRange.Value ws.Protect 123 Next ws

تم معالجة الامر posting.xlsm

تفضل لعل هذا ما تبحث عنه لقد تم الغاء خلايا الدمج وتسمية الاوراق بالانجليزي حتى يعمل الكود ملاحظة اخيرة لا تضغط الملف مرة اخرى posting.xlsm

تم معالجة الامر الكود Option Explicit Sub Get_ALL() Dim Arr(), m, I, itm Dim Ro%, Col%, My_sum# Dim k% m = 1 Principal.Range("B7:B13").ClearContents If Application.CountA(Principal.Range("B4:B6")) < 3 Then MsgBox "Incomplete Data" & Chr(10) & _ "Ckeck Up For Empty The Cells,B4,B5,And B6" Exit Sub End If If Principal.Range("B4") > Sheets.Count - 1 Then Principal.Range("B4") = 1 End If If Principal.Range("B5") > Sheets.Count - 1 Then Principal.Range("B5") = Sheets.Count - 1 End If If Principal.Range("B5") < Principal.Range("B4") Then Principal.Range("B5") = Principal.Range("B4") End If m = 1 For I = Principal.Range("B4") To Principal.Range("B5") ReDim Preserve Arr(1 To m) Arr(m) = Sheets(Principal.Range("B4") + m).Name m = m + 1 Next '++++++++++++++++++++++++++++++++++ For k = 7 To 13 For Each itm In Arr Ro = Sheets(itm).Range("B4:B21").Find(Principal.Range("B6"), lookat:=1).Row Col = Sheets(itm).Range("C3:Z3").Find(Principal.Range("A" & k), lookat:=1).Column + 2 My_sum = My_sum + Val(Sheets(itm).Cells(Ro, Col)) Next itm Principal.Range("B" & k).Value = My_sum My_sum = 0 Next k End Sub الملف مرفق MaKhazin.xlsm

كان من المفترض توضيح ما تريد حتى يتم العمل على الملف منذ البداية تفضل نصرالدين البلداوي.xlsm

تم معالجة الامر تفضل نصرالدين البلداوي.xlsm

اخي الكريم خبرتي ضعيفه لكن ساعطيك كود ترحيل من خلايا مختلفه وجدته في المنتدى حاولت يمكن ان اكتب اسم الصفحه المراد الترحيل بها بدل من Sheets(1) وفشلت انمنى من اصحاب الخبره التعديل فيه Dim EndRow As Long For I = 2 To 2 EndRow = Sheets(I).Range("B1").CurrentRegion.Rows.Count Sheets(I).Cells(EndRow + 1, 1).Value = Sheets(1).Cells(2, 5).Value Sheets(I).Cells(EndRow + 1, 2).Value = Sheets(1).Cells(2, 3).Value Sheets(I).Cells(EndRow + 1, 3).Value = Sheets(1).Cells(4, 3).Value Sheets(I).Cells(EndRow + 1, 4).Value = Sheets(1).Cells(6, 3).Value Sheets(I).Cells(EndRow + 1, 7).Value = Sheets(1).Cells(8, 3).Value Sheets(I).Cells(EndRow + 1, 5).Value = Sheets(1).Cells(7, 8).Value Sheets(I).Cells(EndRow + 1, 6).Value = Sheets(1).Cells(10, 2).Value Next I وهذا شيت الطباعه الذي استخدمه بعد ان احدد نطاق الطباعه مسبقا Sheets("الفاتوره").PrintOut Copies:=1, Collate:=True Application.ScreenUpdating = False اتمنى ان تستفيد منه

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

رضا الناس غاية لا تدرك .. ورضا الله غاية لا تترك ..فإترك مالا يدرك .. وأدرك مالا يترك .. يصعُب إرضاء النّاس ،، لسبب بسيط جدّا ،، و هو ،، أنّ كلّ شخص بحسب بيئته التّي نشأ فيها ،، و حسب عادات و تقاليد مجتمعه ،، و حسب مستواه العلمي ،، بتجاربه في الحياة ،،له تفكير خاصّ به و أراءه المستقلّة ،، و بذلك كيانُه المُستقلّ ،، لذلك هو كائن فريد ،، لا يُشابهه أيّ إنسان آخر ،، لذلك من يُعجب شخصا ما ،، ليس بالضرورة أن يُعجب الآخرين ،، لذلك لن نُرضي النّاس أبدا ،، قد نُرضي البعض على حساب البعض الآخر ،، لان رضا الناس غاية لا تدرك ابدا فمستحيل فعلا ارضاءهم ابدا لذلك من جعل همه ارضاء الله نال وفاز فإن الدنيا زائلة والله والفائز من يعمل ويجتهد في رضا الله سبحانه وتعالى لا رضا الناس

بارك الله فيك ورحم الله والديك

اللهم انا نسألك رضاك والجنة - ونعوذ بك من سخطك و النار

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

جميل جداً جداً ويصف الواقع