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

يمكنت تبديل "" إلى صفر من خلال المعادلة Copy of Book1_02.xlsx

السلام عليكم و رحمة الله اليك الملف السابق بعد تنفيذ الكود فى نفس الخلية المحتوية للعبارة و هى الخلية C2 ان كان الكود يؤدى نتيجة مختلفة . ارجو ارسال ملف موضحا فيه النتيجة المطلوبة حذف الحروف.xlsm

حسب مرفق الاستاذ العراقي ومشاركتكم استاذ موسى يكون العدد 8 ولكن هناك اخر تكرار في الجدول مع اختلاف رقم id Teachers ID TeacherName city country 5 زينب محمد علي القاهرة مصر 10 زينب محمد علي القاهرة مصر وبالتالي اذا كان فهمي صحيح يكون العدد بدون التكرار 7 Unique Value ID TeacherName CountOfcity country 1 احمد محمد 2 العراق 2 محمد حسنين 2 العراق 4 حسين علي 1 العراق 5 زينب محمد علي 2 مصر 6 منى عبد الرحمن 1 العراق 7 سامر محمد 1 مصر 9 سهى عبد الخالق 1 مصر هذا الرد بناء على فهمي للامر وليس للمشاركة في الحل تحياتي

السلام عليكم ورحمة الله تعالى وبركاته تفضل أخي إستبدل الأكواد الموجودة في الملف بهذا الكود : Sub SUM_MH() Dim lastrow As Long, i As Long, officena As Long, MH As Long Application.DisplayAlerts = False Call cler_rng officena = 1 Application.ScreenUpdating = False Application.DisplayAlerts = False With ThisWorkbook.Worksheets("رصيد") lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 1 To lastrow If .Range("A" & i).Value = "اجمالي مخزن الخامات" Or .Range("A" & i).Value = "اجمالي مخزن الرئيسي" Or .Range("A" & i).Value = "اجمالي مبنى الإنتاج" Then MH = i - 1 .Range("B" & i).Value = Application.Sum(.Range(.Cells(officena, 2), .Cells(MH, 2))) .Range("B" & lastrow) = .Range("B" & lastrow) + .Range("B" & i) officena = i + 1 End If Next i For i = Last To 2 Step -1 If (Cells(i, "A").Value) = "الإجمالي الكلي" Then .Range("B" & i).Value = Application.Sum(.Range(.Cells(officena, 2), .Cells(lastrow, 2))) .Range("b" & i).Value = .Range("B" & MH) + .Range("B" & MH) officena = i + 1 End If Next i End With Call Sum_Rng_MH Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub Sum_Rng_MH() Dim sumRange As Range, criteriaRange As Range Dim result As Double Dim i As Integer Dim lastrow As Long Dim R As Range Dim criteria As Variant Set sumRange = Range("B3:B1000") Set criteriaRange = Range("A3:A1000") criteria = Array("اجمالي مخزن الخامات", "اجمالي مخزن الرئيسي") For i = 0 To UBound(criteria) result = WorksheetFunction.Sum(result, _ WorksheetFunction.SumIfs(sumRange, criteriaRange, criteria(i))) Next i Set R = ActiveSheet.Cells.Find("اجمالي المخازن", , xlValues, xlWhole) If Not R Is Nothing Then R.Select ActiveCell.Offset(0, 1).Select ActiveCell.Value = result Range("a2").Activate End Sub Sub cler_rng() Application.ScreenUpdating = False Dim searches As String searches = "اجمالي مخزن الخامات|اجمالي المخازن|اجمالي مخزن الرئيسي|اجمالي مبنى الإنتاج|الإجمالي الكلي" Dim listOfSearches() As String listOfSearches = Split(searches, "|") Dim i As Integer For i = 0 To UBound(listOfSearches) Set R = ActiveSheet.Cells.Find(listOfSearches(i), , xlValues, xlWhole) If Not R Is Nothing Then R.Offset(0, 1).Value = "" Else ActiveCell.Offset(0, 1).Value = "" End If Next i Application.ScreenUpdating = True End Sub Worksheet جديد.xlsm

بما ان هذه المشكلة لا تواجهك الا فى العمل ومن مخزى الرسالة التى تظهر لك ان خاصية الأكواد بالإكسيل لديك مغلقة وغير مفعلة من قبل مسؤل الكمبيوتر لديك IT .. فلابد ان تطلب منه فتحها وجعلها متاحة للإستخدام لك وليس هناك حل نهائياً سوى ذلك وشكراً

تفضل اخي تم تعديل الملف ليتناسب مع طلبك مع بعض الاضافات البسيطة اتمنى ان تلبي المطلوب بادن الله Sub Copie_Sheets_Numérotée_MH() Dim Ind As Integer Dim FlgExist As Boolean, Test As String Application.ScreenUpdating = False Sheet3.Copy After:=Sheets(Sheets.Count) Ind = 2 Do On Error Resume Next Test = Sheets("hakan" & Ind).Range("A1").Value If Err.Number = 0 Then FlgExist = True: Ind = Ind + 1 Else FlgExist = False Loop While FlgExist On Error GoTo 0 ActiveSheet.Name = "hakan" & Ind Sheet2.Select Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub mango_MH3.xlsm

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

بسم الله الرحمن الرحيم السلام عليكم اخوانى . ولكم جميعا كل الشكر والتقدير على مجهودكم ده ملف بسيط فيه كود لحفظ الملف كل عدد معين من الثوانى .. الكود خاص به ا. ياسر ابو براء بارك الله فيه وحفظه من كل سوء انا محتاج اضيف له كود عشان يحفظ الملف فى بارتشن اخر تلقائيا بمعنى يكون عندى نسختين من الملف النسخةالاساسية ونسخة تانية فى بارتشن اخر .. بالبحث فى المنتدى لاقيت الكود ده بس مش عارف اضيفه للكود المرفق ازاى (d) مثلا عشان يحفظ الملف اوتوماتيك كل عدد معين من الثوانى فى النسختين الكود Sub حفظ_الفاتورة() MyNime = Cells.Text & "e:\" & Cells(1, 2).Text & Nombre & ".xls" ActiveWorkbook.SaveCopyAs MyPathDirectory & MyNime End Sub واذا الكود ده مش حينفع و هناك كود اخر يقوم بالمطلوب يبقى تمام ..لكم فائق احترامى وتقديرى تجريبى.xlsm

أخي الفاضل هذه مسألة طبيعية .هذا بسبب أنك تقوم بفتح الملف في نفس المسار الذي يتم حفظه فيه جرب نسخه إلى مكان آخر قبل فتحه وشاهد النتيجة او تغيير صيغة حفظ الملف من xlsM إلى xlsx

اخي الفاضل المسار غير صحيح انشا مجلد داخل بارتشين E Backups باسم ... وقم باستبدال المسار هكدا ActiveWorkbook.SaveCopyAs Filename:="e:\Backups\" & ActiveWorkbook.Name

تعديل المسار بيتم فى كود الموديل فقط مكان ( c:/backup/) فقط ولا هناك اماكن اخرى بعدل فيها المسار .. او اى تعديلات اخرى المفروض اعملها فى الاكواد لان بعد تغيير المسار نفس الخطا

قم بإلغاء حدث workbook حتى تقوم بتعديل مسار حفظ الملف على جهازك. ثم أعد تفعيله من جديد الملف يشتغل عندي بدون مشاكل!!!!!

تفضل اخي Workbook ضع هدا الكود في حدث Private Sub Workbook_Open() Application.OnTime Now + TimeValue("00:00:15"), "SAVE_MH" Call SAVE_MH End Sub Module وهدا في Sub Save_MH() Application.DisplayAlerts = False Application.OnTime Now + TimeValue("00:00:15"), "SAVE_MH" ActiveWorkbook.SaveCopyAs Filename:="c:\Backups\" & ActiveWorkbook.Name ActiveWorkbook.Save Application.DisplayAlerts = True End Sub Sub Save2_MH() Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True Application.OnTime Now + TimeValue("00:00:15"), "Save2_MH" End Sub قد تمت اضافة الكود للملف للتجربة في حالة كانت عندك رغبة بالاحتفاظ بجميع النسخ رغم انني ارى انك في غنى عنها يمكنك جعل الكود بهده الطريقة و تجعلها كل 10 دقائق مثلا Workbook ضع هدا الكود في حدث Private Sub Workbook_Open() Application.OnTime Now + TimeValue("00:10:00"), "save_MH3" 'Application.OnTime Now + TimeValue("00:00:15"), "save_MH3" Call save_MH3 End Sub ---------Module وهدا في---------- Sub save_MH3() Dim MyDate MyDate = Date Dim MyTime MyTime = Time Dim TestStr As String 'تاريخ اليوم TestStr = Format(MyTime, "hh-mm-ss") Dim Test1Str As String 'ساعة الحفظ Test1Str = Format(MyDate, "DD-MM-YYYY") Application.DisplayAlerts = False 'Application.OnTime Now + TimeValue("00:00:15"), "save_MH3" Application.OnTime Now + TimeValue("00:10:00"), "save_MH3" 'تحديد مسار حفظ الملف ActiveWorkbook.SaveCopyAs Filename:="c:\Backups\" & Test1Str & ". " & TestStr & " " & ActiveWorkbook.Name ActiveWorkbook.Save Application.DisplayAlerts = True End Sub Sub Save2_MH() Application.DisplayAlerts = False ThisWorkbook.Save Application.DisplayAlerts = True Application.OnTime Now + TimeValue("00:00:15"), "Save2_MH" End Sub تجريبى-حفظ نسخة من الملف كل 10 دقائق.xlsm تجريبي.xlsm

يمكنك استخدام هذه المعادلة لطلبك ..معادلة مصفوفة (Ctrl+Shift+Enter) =IFERROR(INDEX(Table2[التاريخ],SMALL(IF(Table2[اسم الموقع/ المخزن]=$C$3,ROW($A$4:$A$11)-ROW($A$4)+1),ROWS(A$1:A1))),"") كشف حساب مشروع1.xlsx

وعليكم السلام 🙂 كود اخوي موسى ، ولكن بطريقتي 🙂 Sub CopyFile() Dim sPathDeskTop As String sPathDeskTop = Environ("USERPROFILE") & "\Desktop" & "\b\" ' هنا اسم المجلد الذي سيتم انشاؤه في سطح المكتب Dim CopyFrom As String, CopyTo As String CopyFrom = Me.a ' هذا اسم الحقل الذي به رابط الملف المراد نسخه CopyTo = sPathDeskTop & Dir(CopyFrom) If Len(Dir(sPathDeskTop, vbDirectory)) = 0 Then MkDir (sPathDeskTop) If Len(Dir(CopyTo, vbDirectory)) = 0 Then FileCopy CopyFrom, CopyTo Else MsgBox "هذا الملف موجود مسبقا على سطح المكتب", vbOKOnly Exit Sub End If End Sub جعفر

وعليكم السلام ورحمة الله وبركاته .. تفضل أخي العزيز 🙂 Sub CopyFile() 'Requires reference: :لابد من التأكد من وجود المكتبة الاتية 'Add this reference >>---> Microsoft Scripting Runtime Dim fs Set fs = CreateObject("Scripting.FileSystemObject") Dim sPathDeskTop As String Dim oWSH As Object Set oWSH = CreateObject("WScript.Shell") sPathDeskTop = oWSH.SpecialFolders("Desktop") & "\b\" ' هنا اسم المجلد الذي سيتم انشاؤه في سطح المكتب Dim CopyFrom As String, CopyTo As String CopyFrom = Me.a ' هذا اسم الحقل الذي به رابط الملف المراد نسخه CopyTo = sPathDeskTop & Dir(CopyFrom) If Len(Dir(sPathDeskTop, vbDirectory)) = 0 Then MkDir (sPathDeskTop) If Len(Dir(CopyTo, vbDirectory)) = 0 Then fs.CopyFile CopyFrom, CopyTo, True Else MsgBox "هذا الملف موجود مسبقا على سطح المكتب", vbOKOnly Exit Sub End If Set fs = Nothing Set oWSH = Nothing End Sub فقط انتبه للملاحظات المكتوبة في الكود ..

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

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

وعليكم السلام-تفضل على الرغم انك لم تقم برفع ملف توضيحى لطلبك =LEN(A1)

تفضل

بسيطة يمكنك استخدام هذه المعادلة فقط =SUMIFS($C$4:$C$17,$F$4:$F$17,"<>"&"مسدد",$B$4:$B$17,"<"&$H$2) 6.xlsx

بارك الله فيك استاذ حسونة سيتم الرد ان شاء الله من استاذنا الكبير الدكتور محمد طاهر عرفه عندما تتيح له الفرصة لذلك فربما يكون مشغول جداً فى هذه الأوقات .. بالتوفيق ان شاء الله للأستاذ ابراهيم الحداد وان شاء الله سيعود له حسابه القديم

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

تفضل استاذ منير طبعاً بعد اذن استاذنا الكبير ابراهيم .. فالكود يعمل بكل كفاءة وان حدث اى مشكلة معك فبسببك انت لأنك لم تضع الكود كما يجب ان يكون بالملف وشوف بنفسك حتى يتم اغلاق المشاركة Private Sub CommandButton1_Click() arr = Array("B5", "C5", "F5", "C8", "E9", "G10") tmp = Array(TextBox1.Value, TextBox4.Value, TextBox3.Value, _ TextBox2.Value, TextBox5.Value, TextBox6.Value) For i = LBound(arr) To UBound(arr) Range(arr(i)) = tmp(i) Next For Each Ctrl In Me.Controls If TypeName(Ctrl) = "TextBox" Then Ctrl.Value = "" End If Next Ctrl End Sub ترحيل إلى خانات متفرقة.xlsb

تفضل وأكثر مما تريد فورم ادخال وتعديل وحذف.xlsm

وعليكم السلام-جرب هذا =IF(INT(C2)<>C2,C2+1.5,C2) 1اضافة عدد للكسر.xlsx

أكرمك الله استاذ مجدى وأحسن الله اليك

بارك الله فيك استاذ مجدى وزادك الله من فضله

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

بارك الله فيك استاذ مجدى وزادك الله من فضله

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

أحسنت استاذ مجدى كل عام وأنتم بخير

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