محمد هشام.

وعليكم السلام ورحمة الله وبركاته ..جرب اخي وضع هدا الكود 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

wor1.xlsm

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

Sub copy_columns_MH() Dim MH As Long, k As Long Dim lr As Integer, erow As Integer, sh1 As Worksheet, sh2 As Worksheet, i As Long Set sh1 = Worksheets("saad") Set sh2 = Worksheets("data") Application.ScreenUpdating = False Range("c10:L10000").ClearContents lr = sh1.Cells(Rows.Count, 3).End(xlUp).Row For i = 11 To lr erow = sh2.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row sh2.Cells(erow, 4) = sh1.Cells(i, 2) sh2.Cells(erow, 5) = sh1.Cells(i, 4) sh2.Cells(erow, 6) = sh1.Cells(i, 5) sh2.Cells(erow, 7) = sh1.Cells(i, 7) sh2.Cells(erow, 8) = sh1.Cells(i, 9) sh2.Cells(erow, 9) = sh1.Cells(i, 10) sh2.Cells(erow, 10) = sh1.Cells(i, 11) sh2.Cells(erow, 11) = sh1.Cells(i, 12) sh2.Cells(erow, 12) = sh1.Cells(i, 15) Next i With Sheets("data") k = 1 For MH = 10 To .Range("D" & .Rows.Count).End(xlUp).Row If .Range("C" & MH) = valeu Then .Range("C" & MH) = k k = k + 1 End If Next MH End With Application.ScreenUpdating = True End Sub AHMAD - MH-3.xlsm

الملف الذي تم إرفاقه في المشاركة فوق ليس به أي مشكلة في الترحيل ربما قد غيرت شيئ ما بدون قصد على العموم قد تم حل المشكلة أما بالنسبة للتسطير كان عليك أولا تجرب تسطير ورقة saad وتشوف!!! تم إرفاق ملفان واحد بتسطير ورقة saad والثاني باستخدام التنسيق الشرطي .لكي تكتشف الفرق AHMED.rar

اقتراح ..يمكنك بعد وضعهم في ملف واحد اضافة ورقة جديدة تمكنك من استخراج المتغير بما ان رقم الهوية الوطنية هو عنصر ثابت لا يتغير يمكنك البحث به رغم اختلاف ترتيب الاسماء بمصنف1 و2 وطريقة البحث هي الاسم والهوية الوطنية من مصنف 1 لاعتبارة الشيت الرئيسي الدي يتضمن جميع الاسماء مع جلب باقي البيانات من مصنف 2 بشرط وجود نفس الاسم وعند كتابة الرقم الوظيفي فقط يتم جلب بيانات الاعمدة الاخرى تلقائيا..جرب اخي test.xlsx

السؤال لماذا لم يتم نسخ البيانات الجديدة فوق القديمة او جلبها دفعة واحدة دون تحديث كل اسم على حدى ؟ او ترحيل الأعمدة الأربعة فقط للمصنف الجديد!!!! لانه ليس هناك تغيير لا في مكان الأعمدة ولا في تنسيق الجدول . هل هناك اعمدة أخرى يجب تحديث بياناتها ؟

AHMAD - MH-2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تم انشاء كود جديد يلبي المطلوب بادن الله Sub M_H() Dim i As Long Dim MH As Long, k As Long Application.ScreenUpdating = False With Sheets("saad") lr = Cells(Rows.Count, 1).End(3).Row 'افراغ النطاق من البيانات السابقة قبل الترحيل Sheets("data").Range("c10:l" & lr).ClearContents lrow = .Cells(Rows.Count, 2).End(xlUp).Row ' الاعمدة المطلوب ترحيلها frt = Split("B,D,E,G,I,L,J,K,O", ",") 'الاعمدة المرحل اليها tot = Split("D,E,F,G,H,K,I,J,L", ",") For i = LBound(frt) To UBound(frt) 'نسخ البيانات ابتداءا من الصف العاشر .Range(frt(i) & "10:" & frt(i) & lrow).Copy Sheets("Data").Range(tot(i) & "10") Next i End With ' ترقيم تلقائي للصفوف المرحلة بشرط وجود قيمة في 'العمود(D) 'ابتداءا من الصف العاشر With Sheets("data") k = 1 For MH = 10 To .Range("D" & .Rows.Count).End(xlUp).Row If .Range("C" & MH) = valeu Then .Range("C" & MH) = k k = k + 1 End If Next MH End With ' كود اظافي 'With Sheets("data") '.Range("C10") = 1 '.Range("C11") = 2 '.Range("C10:C11").AutoFill .Range("C10:C" & lrow) 'End With End Sub AHMAD-MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي بعد تحميل الملف المضغوط سوف تجد مجلد باسم DATA C قم بنسخه الى القرص ثم افتح ملف سجل القيد وقم باستدعاء البيانات عادي الكود المستخدم Sub MH_data() Application.ScreenUpdating = False Set currentworkbook = ThisWorkbook Set sourceworkbook = Workbooks.Open("C:\DATA\Sheet1.xlsx") sourceworkbook.Worksheets("Sheet1").Range("a2:d500").Copy currentworkbook.Activate currentworkbook.Worksheets("Sheet1").Activate lastcell = Cells(Rows.Count, 2).End(xlUp).Row + 1 currentworkbook.Worksheets("Sheet1").Cells(lastcell, 2).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False sourceworkbook.Close Set sourceworkbook = Nothing Set currentworkbook = Nothing ThisWorkbook.Activate Worksheets("Sheet1").Activate Worksheets("Sheet1").Range("A4").Select Application.ScreenUpdating = True End Sub ملاحظة: يمكنك تغيير مسار الملف من هنا في حالة عدم توفر جهازك على قرص باسم C Set sourceworkbook = Workbooks.Open("C:\DATA\Sheet1.xlsx") سجل القيد_MH.rar

تفضل اخي Sub Hide_Rows_Zero_MH() Dim x1 As Long Dim x2 As Long Dim MH As Boolean For x1 = 4 To 15 MH = True For x2 = 2 To 5 If Cells(x1, x2).Value > 0 Then MH = False Exit For End If Next x2 Rows(x1).Hidden = MH Next x1 End Sub وهدا لاظهارها Sub shw_row() lr = Cells(Rows.Count, 1).End(4).Row Range("a4:a" & lr).EntireRow.Hidden = False End Sub اخفاء الصفوف الفارغة.xlsm

جرب مشروع.xlsx اخي