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

وعليكم السلام-تفضل =IFERROR(INDEX($G:$G,MATCH($C3,$H:$H,0)),"لا يوجد") Book3.xlsx

يمكنك استخدام هذه المعادلة على الرغم انك لم توضح أين يتم وضع معادلة البحث ,, فقد تـــم عمل وتنظيم كل شيء ..فقد تم عمل قائمة منسدلة بكل أرقام السيارات ما عليك سوى إختيار السيارة المراد البحث عنها واترك الباقى على الإكسيل =LOOKUP(2,1/($B$2:$B$500=$N2),$G$2:$G$500) 1تموين سولار.xlsb

تفضل وشكراً واى خدمة وده بطريقة أخرى

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي Private Sub CommandButton1_Click() Dim lr As Integer Dim ws As Worksheet Set ws = Sheet4 With ws lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("a" & lr + 1).Value = Me.TextBox2.Value .Range("b" & lr + 1).Value = Me.TextBox3.Value .Range("c" & lr + 1).Value = Me.TextBox4.Value .Range("d" & lr + 1).Value = Me.TextBox5.Value .Range("e" & lr + 1).Value = Me.TextBox6.Value End With Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox2.SetFocus End Sub

وعليكم السلام ورحمة الله تعالى وبركاته اخي لم تحدد مكان وضع صورة البطاقة !!!!!...اما بالنسبة للصورة الشخصية يمكنك استخدام المعادلة التالية : =INDEX('ادخال البيانات'!$B$8:$C$300;EQUIV('فورم البيانات'!$B$10;'ادخال البيانات'!$C$8:$C$300;0);1) تجريبى.xls

كالعادة يأخى دايما متألق ..بارك الله فيك

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub Data_Transfer() On Error GoTo Fin Application.ScreenUpdating = False Dim MH%, MH2%, F MH = [A65500].End(xlUp).Row For Each F In Worksheets If F.Name <> "Input" Then With Sheets(F.Name) .Range("A1:E10000").ClearContents .Cells(1, 1) = F.Name: .Cells(1, 2) = "Kg": .Cells(1, 3) = "€" End With End If Next F For L = 2 To MH Feuille = Cells(L, "A") If Feuille = "" Then Exit Sub With Sheets(Feuille) .Cells(.[C65500].End(xlUp).Row + 1, 2) = Cells(L, 3) .Cells(.[C65500].End(xlUp).Row + 1, 3) = Cells(L, 5) End With Next L Exit Sub Fin: MsgBox "The sheet " & Cells(L, "A") & " does not exist." End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub clear() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "Input" Then ws.Range("a1:c1000").ClearContents End If Next ws End Sub Kopie von obst_MH.xlsm

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

شكرا لك ا / Ali Mohamed Ali وجعله الله فى ميزان حسناتك

وكيف تنتظر المساعدة من أحد بدون رفع الملف ؟!!هل يمكن العمل على الصورة ؟!!لا يمكن العمل على التخمين وتجنباً لإهدار وقت الأساتذة دون جدوى أو أهمية فلابد من رفع ملف مدعوم بشرح كافى عن المطلوب !!!

السلام عليكم و رحمة الله استخدم هذه المعادلة =((D5+E5)+(F5*2))/4

وعليكم السلام ورحمة الله وبركاته من خيارات الاوفيس في تبويب مصممو العناصر ضع او ازل اشارة الصح من امام استخدام امر الحدث دوما

أحسنت أستاذ ماجد بارك الله فيك

بارك الله فيك ونفع الله بعلمك وزادك الله من فضله.. بالفعل معلومة قيمة وبالطبع سيستفيد منه الجميع وشكراً جزيلاً لحضرتكم وجزاك الله خير الثواب

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي الكريم هدا حل اخر بالاكواد مع بعض الاضافات البسيطة ربما يلبي طلبك في حدث شيت Nesma Private Sub Worksheet_Activate() Dim li As Integer, MH1 As Integer, A As Integer, Y As Integer A = Sheets("Parts").Range("G" & Rows.Count).End(xlUp).Row Y = Sheets("Parts").Cells(2, Cells.Columns.Count).End(xlToLeft).Column + 1 Application.ScreenUpdating = False Worksheets("Nesma").Range("A4:C1000").ClearContents For li = 5 To A For MH1 = 3 To 3 Sheets("Nesma").Cells(li - 1, MH1) = Sheets("Parts").Cells(li, MH1) Sheets("Nesma").Cells(li - 1, MH1 - 1) = Sheets("Parts").Cells(li, MH1 + 3) Sheets("Nesma").Cells(li - 1, MH1 - 2) = Sheets("Parts").Cells(li, MH1 + 4) Next Next Application.ScreenUpdating = True End Sub وهدا في حدث شيت Wheels Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lr As Long Application.ScreenUpdating = False Worksheets("Parts").Range("G5:G1000").ClearContents With Sheets("Wheels") lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(4, "b"), .Cells(lr, "b")).Copy Sheets("Parts").Cells(5, "G") .Range(.Cells(4, "c"), .Cells(lr, "c")).Copy Sheets("Parts").Cells(5, "f") End With Application.ScreenUpdating = True End Sub OR_more_100 values_MH.xlsm

يالضبط دكتور محمد طاهر وهذا بالفعل الذى يتم

لا يمكن ذلك لأن ذلك سيتم بأكواد vba وهى بدورها لا تعمل على التليفون وشكراً

وعليكم السلام أولاً لعمل منع تكرار بعمود رقم السيارة واسم المالك مجتمعين .. فيمكنك استخدام هذه المعادلة من خلال خاصية Data Validation =COUNTIFS($A$2:$A$2000,$A2,$B$2:$B$2000,$B2)=1 ولعمل حماية لصفحة البيانات بدون أكواد فعليك بالدخول على قائمة Developer ثم Visual Basic أو بالضغط على Alt F11 للدخول على محرر الأكواد ثم بعد ذلك اتبع الصورة المرفوعة للتعلم ..واذا أردت فك الحماية وإظهار الصفحة اتبع نفس الخطوات ولكن عليك بلإختيار الأول وهو -1-Sheetvisible ..كما تم حذف كل المكرر من البيانات وضبط الملف وشكراً متابعة الملاك.xlsx

ارفع من فضلك الملف أو صورة من المشكلة التى تحدث لك فهذا هو الحل الوحيد لهذه المشكلة !!!

أستاذى الكريم AbuuAhmed لما كل هذا القلق والغضب ؟!! طالما ان الغرض الأساسى هو افادة الأعضاء حتى اثناء غلق الموضوعات والمشاركات تظل الإستفادة قائمة وكما أوضح لك أستاذنا الكريم محمد طاهر اننا قد اتفقنا سلفاً على غلق الموضوعات والمشاركات حتى لا تكثر الحوارات والمشاركات الجانبية بها .. طالما بالفعل تم الإستفادة والرد الكافى بالموضوع وشكراً .. وكما تعلم يقيناً استاذنا الكريم ويعلم الله أنا دائماً وأبداً أكون من أكثر الناس تشجعياً ووقوفاً أمام وخلف جميع الأعضاء فى أى شيء ..وشكراً

وعليكم السلام أحسنت استاذنا الكريم عمل ممتاز بارك الله فيك والى الأمام دائماً وبالتوفيق والنجاح دوماً

بسيطة بعد اذن طبعاً الأستاذ ابراهيم ..عليك بإضافة هذا السطر بالكود قبل نهايته TextBox2.Text = Format(Val(TextBox2.Text), "0.0") تجريبى1.xlsm

طيب تفضل ... التعديلات ::::::: 1- اضفنا حق ch في الجدول 2- عملنا استعلام بالسجلات المختارة 3- ادرجنا زر وبه الامر التالي ::::: 4- جرب المرفق .. Dim DTPath As String DTPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\salim07- " & Format(Date, "dd-mm-yyyy") & ".xlsx" DoCmd.OutputTo acOutputQuery, "استعلام1", acFormatXLSX, DTPath, False MsgBox "لقد تم تصدير البيانات بنجاح" TEST 12.accdb

تفضل هذا هو الملف وبه الكود Book1.xlsm

السلام عليكم ورحمة الله وبركاته وكل عام وانتم جميعا بخير ورمضان مبارك علينا جميعا -تقبل الله منا سائر الأعمال اقدم لكم اليوم برنامج حسابات شامل ومتعدد-من حسابات لشركات وايضا للمخازن وبه ايضا شئون عاملين (من وضع المكافات والجزاءات والسلف للعاملين والموظفين الى صرف المرتبات والمستحقات) ومع الملف فيديوهات للشرح ونظرا لكبر حجم الملف فقمت برفعه على موقع خارجى تقبل الله منا ومنكم الصيام والصلاة والقيام-جزاكم الله كل خير http://www.mediafire.com/file/h3vh1cwint9s95p/برنامج+حسابات+المقاولات.rar

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

يمكنك تجربة هذا الكود Sub JPGActiveSheet() 'www.contextures.com 'for Excel 2010 and later Dim wsA As Worksheet Dim wbA As Workbook Dim strTime As String Dim strName As String Dim strPath As String Dim strFile As String Dim strPathFile As String Dim myFile As Variant On Error GoTo errHandler Set wbA = ActiveWorkbook Set wsA = ActiveSheet strTime = Format(Now(), "yyyymmdd\_hhmm") 'get active workbook folder, if saved strPath = wbA.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" 'replace spaces and periods in sheet name strName = Replace(wsA.Name, " ", "") strName = Replace(strName, ".", "_") 'create default name for savng file strFile = strName & "_" & strTime & ".jpg" strPathFile = strPath & strFile 'use can enter name and ' select folder for file myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="jpg Files (*.jpg), *.jpg", _ Title:="Select Folder and FileName to save") 'export to PDF if a folder was selected If myFile <> "False" Then wsA.ExportAsFixedFormat _ Type:=xlTypePDF, _ filename:=myFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False 'confirmation message with file info MsgBox "jpg file has been created: " _ & vbCrLf _ & myFile End If exitHandler: Exit Sub errHandler: MsgBox "Could not create jpg file" Resume exitHandler End Sub

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

تفضل هذا الملف تغيير لون الخلايا.xlsx

أعتقد ان هذا هو المطلوب توزيع ارباح-3.xlsx

جزاك الله كل خير وكل عام وانتم بخير

تفضل أستاذى توزيع ارباح-2.xlsx

ممكن تجرب هذا تقييد الخلايا مع شرط رابع.xls

تفضل جرب هذا توزيع ارباح-1.xlsx

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

أهلا وسهلا بك فى منتدانا الكريم من الأفضل ارسال الملف للعمل عليه ولكن يمكنك وضع هذه المعادلة فى الخلية التى تريدها لإعطاء الوقت والتاريخ الحاليين =TEXT(TODAY(),"d/m/yyy")&" "&TEXT(NOW(),"hh:mm:ss") وهناك ايضا هذا الكود لجعل الوقت يعمل وشغال بأستمرار Sub Date_Time() On Error Resume Next 1 DoEvents N = Now Range("c13") = Format(N, "[$-F400]h:mm:ss AM/PM") T = T + 1 For r = 1 To 10000000: Next r GoTo 1 End Sub وهذا كود اخر يمكنك اضافته فى حدث الورقة بحيث اذا قمت بتسجيل اى شيء فى العمود B سيضهر لك التاريخ فى العمود C والوقت فى العمود D Private Sub Worksheet_Change(ByVal Target As Range) n = Now If Target.Column = 2 Then If Target = "" Then Cells(Target.Row, Target.Column + 1) = "" Cells(Target.Row, Target.Column + 2) = "" Exit Sub ElseIf Target <> "" Then Cells(Target.Row, Target.Column + 1) = Date Cells(Target.Row, Target.Column + 2) = Time End If End If End Sub بارك الله فيك