محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته نعم اخي لازم تقوم بتعديل المعادلة على حسب متطلباتك بتغيير الارقام كما في الصورة المرفقة وعليها مثال لطلبك Book1.xlsx

وعليكم السلام ورحمة الله تعلى وبركاته Sub Clear_Cells() Dim mh_last_row As Long Dim k As Long Application.ScreenUpdating = False mh_last_row = Cells(Rows.Count, "d").End(xlUp).Row For k = 4 To mh_last_row If Cells(k, "a").Value = "" Then Range(Cells(k, "d"), Cells(k, "f")).ClearContents Next k Application.ScreenUpdating = True End Sub كود.xlsb

تفضل اخي test_gold.xlsx

تضل اخي الفاضل هدا كود اخر لانشاء ورقة جديدة وتسميتها باخر قيمة موجودة على عمود A Sub Bouton1_Cliquer() Dim lastLine As Integer Dim NameSheet As String Dim MH As Boolean lastLine = ThisWorkbook.Sheets("toutal").Range("A" & Rows.Count).End(xlUp).Row NameSheet = ThisWorkbook.Sheets("toutal").Range("A" & lastLine) MH = feuilleExiste(NameSheet) If MH = True Then MsgBox "يتعذر انشاء ورقة جديدة بسبب وجودها مسبقا او خانة الاسم فارغة", vbInformation Else Worksheets("hakan").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = Worksheets("toutal").Cells(Rows.Count, 1).End(xlUp).Value ThisWorkbook.Sheets("toutal").Activate End If End Sub Function feuilleExiste(FeuilleAVerifier As String) As Boolean On Error Resume Next ThisWorkbook.Sheets(FeuilleAVerifier).Name = Sheets(FeuilleAVerifier).Name feuilleExiste = (Err.Number = 0) End Function mango_MH4.xlsm

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

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

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي جرب تم تعديل صيغة الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim e As Integer Dim LastRowInSheet As Long Dim d As Variant Dim f As Variant Dim InputArray As Variant Application.ScreenUpdating = False LastRowInSheet = Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row InputArray = Range("A1:N" & LastRowInSheet) e = d + f For d = 4 To 99 For f = 100 To 1000 Step 100 InputArray(d, 1) = InputArray(d, 3) - InputArray(d, 2) + InputArray(d - 1, 1) InputArray(d, 12) = InputArray(d, 11) * InputArray(d, 10) InputArray(d, 14) = InputArray(d, 13) * InputArray(d, 10) InputArray(d, 10) = InputArray(d, 9) * InputArray(d, 8) InputArray(d + f - 3, 1) = InputArray(d + f - 3, 3) - InputArray(d + f - 3, 2) + InputArray(d + f - 4, 1) InputArray(d + f - 3, 12) = InputArray(d + f - 3, 11) * InputArray(d + f - 3, 10) InputArray(d + f - 3, 14) = InputArray(d + f - 3, 13) * InputArray(d + f - 3, 10) InputArray(d + f - 3, 10) = InputArray(d + f - 3, 9) * InputArray(d + f - 3, 8) Next Next Range("A1:N" & LastRowInSheet) = InputArray Application.ScreenUpdating = True End Sub نمودج-2.xlsb

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

يمكنك اخي بجعل الكود بهده الطريقة 'حيث يتم اظهار الرسالة فقط عند كتابة اسم محمد او سعيد فقط Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 Then If (Target.Offset(0, 2).Value = "") And ((Target.Value = "محمد") Or (Target.Value = "سعيد")) Then MsgBox "تاكد من مركز التكلفة " Target.Offset(0, 2).Select End If End If End Sub رسالة.xlsm

تفضلي اختي الفاضلة Invoices-j.xlsm

يمكنك اخي دالك بجعل الكود بهده الطريقة Sub Undo_add_change() Dim Sheet As Worksheet Dim liste1 As Variant Dim liste2 As Variant Dim MH As Long Dim Rng As Range Set Sheet = Sheets("سجل وسط نهاية السنة") Set Rng = Range("D6:L45") Application.ScreenUpdating = False For i = 6 To 45 liste1 = Array("49.5 50", "49 50", "48.5 50", "48 50", "47.5 50", "47 50", "46.5 50", "46 50", "45.5 50", "45 50") liste2 = Array("49.5", "49", "48.5", "48", "47.5", "47", "46.5", "46", "45.5", "45") For MH = LBound(liste1) To UBound(liste1) If Range("R" & i).Value = "راسب" Then Range("d" & i, "k" & i).Cells.Replace What:=liste1(MH), Replacement:=liste2(MH), _ LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, _ SearchFormat:=True, ReplaceFormat:=True Rng.Font.Size = 11 Rng.Font.Name = "Arial" If Range("R" & i).Value = "راسب" Then Range("d" & i, "k" & i).Cells.Font.Strikethrough = False End If End If Next MH Next i Application.ScreenUpdating = True End Sub تراجع_2.xlsm

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي هدا كود للتراجع فقط عن الدرجات المضافة للطالب الراسب. Sub Undo_add_change() Dim Sheet As Worksheet Dim liste1 As Variant Dim liste2 As Variant Dim MH As Long Dim Rng As Range Set Sheet = Sheets("سجل وسط نهاية السنة") Set Rng = Range("d6:L45") Application.ScreenUpdating = False For i = 6 To 45 liste1 = Array("49.5 50", "49 50", "48.5 50", "48 50", "47.5 50", "47 50", "46.5 50", "46 50", "45.5 50", "45 50") liste2 = Array("49.5", "49", "48.5", "48", "47.5", "47", "46.5", "46", "45.5", "45") For MH = LBound(liste1) To UBound(liste1) If Range("R" & i).Value = "راسب" Then Range("d" & i, "k" & i).Cells.Replace What:=liste1(MH), Replacement:=liste2(MH), _ LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, _ SearchFormat:=True, ReplaceFormat:=True End If Next MH Next i With Sheets("سجل وسط نهاية السنة") Rng.Font.Size = 11 Rng.Font.Name = "Arial" Rng.Font.Strikethrough = False End With Range("M3").Select Application.ScreenUpdating = True End Sub وهدا كود لاضافة درجات القرار : Sub Add_Resolution_2() Dim i As Long Dim MH As Long, k As Long Application.ScreenUpdating = False With Sheets("سجل وسط نهاية السنة") lrow = .Cells(Rows.Count, 32).End(xlUp).Row liste1 = Split("AF,AG,AH,AI,AJ,AK,AL,AM,AN, AO, AP, AQ, AR", ",") liste2 = Split("D,E,F,G,H,i,j,k,L,M,N,O,P", ",") For i = LBound(liste1) To UBound(liste1) .Range(liste1(i) & "6:" & liste1(i) & lrow).Copy Sheets("سجل وسط نهاية السنة").Range(liste2(i) & "6") Application.ScreenUpdating = True Next i End With End Sub تراجع_2.xlsm

هذا هو الموجود فعلا على الملف عند كتابة رقم الوصل يتم جلب بياناته من ورقة transaction قد تم وضع القائمة للتجربة فقط Imprimer-3.xlsm

تفضل اخي جرب Imprimer-3.xlsm

'بعد ادن الاستاد عبدالفتاح في بي اكسيل Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 Then If Target.Offset(0, 2).Value = "" Then MsgBox "تاكد من مركز التكلفة" Target.Offset(0, 2).Select End If End If End Sub رسالة.xlsm

السلام عليكم ورحمة الله تعالى وبركاته تفضل أخي إستبدل الأكواد الموجودة في الملف بهذا الكود : 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

تفضل اخي تم تعديل الملف ليتناسب مع طلبك مع بعض الاضافات البسيطة اتمنى ان تلبي المطلوب بادن الله 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

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

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

قم بإلغاء حدث 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

اخي لا اعلم الغرض من الفكرة لاكن اظن انه من الانسب لصق جميع القيم مباشرة وحدفها بعد الانتهاء من العد ادا لزم الامر اليك بديل ربما يناسبك نسخ جميع القيم من شيت البيانات الى شين فاتورة مع كود لتصفح القيم المحصل عليها واستخراج عددها . Sub cal() Dim MH& With Worksheets("البيانات") Range("A3:A50").ClearContents Range("B2").ClearContents MH = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 Worksheets("فاتورة").Range("A1").Resize(MH).Value = .Columns(1).Resize(MH).Value Application.Goto Worksheets("فاتورة").Range("A2") End With For MH = 1 To MH With Worksheets("فاتورة") Range("b2").Value = MH End With Next MH End Sub Private Sub worksheet_selectionchange(ByVal target As Range) Dim r As Range With Me Application.Calculation = xlManual MH = .Cells(.Rows.Count, 1).End(xlUp).Row Set r = Intersect(target, .Columns(1).Resize(MH)) If Not r Is Nothing Then If r.Cells.Count = 1 Then PrevColor = r.Interior.Color r.Interior.Color = vbGreen Application.Wait Now + TimeValue("00:00:01") r.Interior.Color = PrevColor r.Offset(1).Activate Application.ScreenUpdating = False ActiveWindow.ScrollRow = 1 Range("A2:A50").ClearContents Application.Calculation = xlAutomatic Application.ScreenUpdating = True End If End If End With End Sub كود عداد الارقام.xlsm

صراحة لم أستوعب الطلب جيدا ...جرب أخي Sub cal_MH() Dim LastRow As Long Dim i As Long, j As Long Application.Calculation = xlManual With Worksheets("البيانات") LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 End With For i = 1 To LastRow With Worksheets("فاتورة") Application.Wait (Now + TimeValue("00:00:01")) Range("A2").Value = i End With Next i Application.Calculation = xlAutomatic End Sub كود يقوم بقراءة الارقام عدها أي تسلسل الارقام.xlsm

Sub Convert_Formula_To_VBA() Dim ws As Worksheet, lr As Long Set ws = ThisWorkbook.Worksheets("Sheet1") Application.ScreenUpdating = False With ws lr = .Cells(Rows.Count, 2).End(xlUp).Row With .Range("C2:C" & lr) .Formula = "=COUNTA(A2,B2)" .Value = .Value End With End With Call Convert_Formula_To_VBA2 Application.ScreenUpdating = True End Sub كما يمكنك وضع الكود بهذه الطريقة Sub Convert_Formula_To_VBA3() Dim ws As Worksheet, lr As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Sheet1") With ws lr = .Cells(Rows.Count, 2).End(xlUp).Row With .Range("C2:C" & lr) .Formula = "=COUNTA(A2,B2)" .Value = .Value End With With ws With .Range("D2:D" & lr) .Formula = "=COUNTA(A2,B2,C2)" .Value = .Value End With End With End With Application.ScreenUpdating = True End Sub

تفضل اخي Sub MH_copy() Dim i As Long Application.ScreenUpdating = False With Cells(1).CurrentRegion For i = 2 To .Rows.Count Step 6 lastro = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1 .Rows(i).Resize(6).Copy Range("c" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True Next End With If Range("c3").Value <> "" Then Range("C2:h" & lastro).Select With Range("C2:h" & lastro).Borders.LineStyle = xlNone Range("C2:h" & lastro).Borders.LineStyle = xlContinuous Range("a1").Select Application.ScreenUpdating = True End With End Sub 1.xlsm