محمد هشام.

'بعد ادن الاستاد عبدالفتاح في بي اكسيل 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

وعليكم السلام ورحمة الله وبركاته ..جرب اخي وضع هدا الكود Sub impr_DocWord_MH() Dim WordApp As Object, worddoc As Object Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") 'قم بوضع ملف الوورد في نفس مسار ملف الاكسيل مع تغيير الاسم باسم الملف الخاص بك Set worddoc = WordApp.Documents.Open(ThisWorkbook.Path & "\TEST.docx", ReadOnly:=True) WordAppActiveDocument.PrintOut 'تحديد أرقام الصفحات المراد طباعتها 'WordApp.ActiveDocument.PrintOut Pages:="2" Application.Wait Now + TimeSerial(0, 0, 2) worddoc.Close savechanges:=False WordApp.Quit Set worddoc = Nothing Set WordApp = Nothing Application.ScreenUpdating = True End Sub وفي المرفقات ملف للتجربة طباعة ملف وورد من داخل الاكسيل.rar

أين هي الفاتورة المصممة مسبقا؟ يمكنك ترحيل الفاتورة من ملف الوورد الى ملف اكسيل بنفس التنسيق والشكل إذا أحببت .

تفضل اخي Sub SUM_MH() Dim LastRow As Long, i As Long, officena As Long, MH As Long Application.DisplayAlerts = False Last = Cells(Rows.Count, "b").End(xlUp).Row For i = Last To 2 Step -1 If (Cells(i, "b").Value) = "الاجمالي العام" Then Range(Cells(i, "c"), Cells(Rows.Count, 5)).ClearContents End If Next i officena = 1 With ThisWorkbook.Worksheets("البيانات") LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row For i = 1 To LastRow If .Range("b" & i).Value = "اجمالي الموردين" Or .Range("b" & i).Value = "اجمالي العملاء" Then MH = i - 1 .Range("C" & i).Value = Application.Sum(.Range(.Cells(officena, 3), .Cells(MH, 3))) .Range("D" & i).Value = Application.Sum(.Range(.Cells(officena, 4), .Cells(MH, 4))) .Range("E" & i).Value = Application.Sum(.Range(.Cells(officena, 5), .Cells(MH, 5))) .Range("C" & LastRow) = .Range("C" & LastRow) + .Range("C" & i) .Range("D" & LastRow) = .Range("D" & LastRow) + .Range("D" & i) .Range("E" & LastRow) = .Range("E" & LastRow) + .Range("E" & i) officena = i + 1 Application.DisplayAlerts = True End If Next i End With End Sub wor1-3.xlsm

بعد ادن استادنا الكبير ابراهيم الحداد واثراءا للموضوع يمكنك استخدام الكود التالي Sub SUM_MH() Dim LastRow As Long, i As Long, officena As Long, MH As Long Application.DisplayAlerts = False officena = 1 With ThisWorkbook.Worksheets("بيانات") LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1 For i = 1 To LastRow If .Range("b" & i).Value = "اجمالي العملاء" Or .Range("b" & i).Value = "اجمالي الموردين" Then MH = i - 1 .Range("C" & i).Value = Application.Sum(.Range(.Cells(officena, 3), .Cells(MH, 3))) .Range("D" & i).Value = Application.Sum(.Range(.Cells(officena, 4), .Cells(MH, 4))) .Range("E" & i).Value = Application.Sum(.Range(.Cells(officena, 5), .Cells(MH, 5))) officena = i + 1 Application.DisplayAlerts = True End If Next i End With End Sub . wor1.xlsm

السلام عليكم ورحمة الله تعالى وبركاته اولا اسف على التاخير لم استطيع امس تعديل المعادلات بسبب ضيق الوقت وعدم توضيحك المسبق لامكانية زيادة اوراق العمل تفضل اخي تم وضع المعادلات لغاية 350 صف قابل للزيادة مع التعرف تلقائيا على اوراق العمل المضافة اما في حالة كانت عندك رغبة بالبحث فقط بالقيمة الموجودة في الخانة B4 يمكنك استبدال الكود الموجود في حدث ورقة toutal بهدا الكود رغم اني ارى ان المعادلات افضل بسبب انها تتيح لك رؤية جميع النتائج الموجودة في اوراق العمل كلها في نفس الوقت Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet If Target.Address = "$B$4" Then Me.Cells(4, 3).Resize(, 12).ClearContents If Not IsEmpty(Target) Then Set ws = Worksheets(Target.Value) Select Case ws.Name Case "toutal": Case Else: With Me .Range("C4") = ws.Range("B11") .Range("D4") = ws.Range("B6") .Range("E4") = ws.Range("B8") .Range("F4") = ws.Range("M6") .Range("G4") = ws.Range("B12") .Range("H4") = ws.Range("B13") .Range("I4") = ws.Range("B17") .Range("J4") = ws.Range("K47") .Range("K4") = ws.Range("L47") .Range("L4") = ws.Range("M47") .Range("M4") = ws.Range("N47") .Range("N4") = ws.Range("C81") End With End Select End If End If End If If Target.Count > 1 Or Target.Row <= 2 Then Exit Sub If Target.Column = 2 And Target.Value <> "" And Not (sheetExists(Target.Value)) Then Call newsh(Target.Value) Sheets("toutal").Select End If End Sub mango_MH.xlsm

اخي لم اكتشف اي خطا بالمعادلة قد تم اعادة تجربها مرة اخرى على ما يبدو لي انها صحيحة .وقمت بمقارنتها مع الملف المرفوع من استادنا الكبير محي الدين ابو البشر . تم الحصول على نفس النتيجة .شهر 8 =SOMME.SI.ENS(E10:E100;F10:F100;">="&D5;F10:F100;"<="&FIN.MOIS(D5;0))+SOMME.SI.ENS(G10:G100;H10:H100;">="&D5;H10:H100;"<="&FIN.MOIS(D5;0))+SOMME.SI.ENS(I10:I100;J10:J100;">="&D5;J10:J100;"<="&FIN.MOIS(D5;0))

جرب اخي هل هو المطلوب فعلا لاني حتى الانتهاء من وضع المعادلات اكتشفت وجود كود لاضافة اوراق جديدة تلقائيا وبهده الطريقة المعادلات الموضوعة لا يمكنها التعرف على الشيت المضاف الا بعد التعديل mango2021-2022-2023 (1).xlsm

وعليكم السلام ورحمة الله وبركاته هل نسخ القيم يقتصر على الأوراق الموجودة أم هناك احتمال الزيادة (hakan11 او 12)

العفو أخي الكريم

وعليكم السلام ورحمة الله وبركاته المرجوا المزيد من التوضيح او إرفاق ملف به نموذج للنتيجة المتوقعة. لأنني بصراحة لم أستوعب طلبك جيدا

Sub MH_hyperkunks() Dim Ws As Worksheet Worksheets("toutal").Range("A3:a100").ClearContents Range("A3").Select For Each Ws In ActiveWorkbook.Worksheets If Ws.Name <> "toutal" Then ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & Ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=Ws.Name ActiveCell.Offset(1, 0).Select End If Next Ws End Sub mango2023(1).xlsm

تفضل اخي مثال توضيحي.xlsx

Sub change_selection() Dim MH_Range, New_Range As Range Set MH_Range = Selection Set New_Range = MH_Range.Resize(, 1).Offset(0, MH_Range.Columns.Count) New_Range.Select End Sub تحديد صف موازى لنطاق.xlsm