محمد هشام.

العفو أخي الكريم يسعدنا أننا إستطعنا مساعدتك إليك طريقة أخرى مع إظافة التنسيقات يمكنك إختيار ما يناسبك Option Explicit Sub Extract_Names2() Dim dict As Object, ColA As Range, ColB As Range, a As Variant, b As Variant Dim tbl As String, Key As Variant, ColE As Long, début As Long, lr As Long, tmp As Range Dim dCount As Long, UniCount As Long, i As Long, Irow As Long, AutoFilterWasOn As Boolean Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) With CrWS.Range("D2:E" & CrWS.Rows.Count) .ClearContents: .Borders.LineStyle = xlNone End With Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB tbl = tmp.Value If Not dict.exists(tbl) Then dict.Add tbl, 1 Else dict(tbl) = dict(tbl) + 1 Next tmp début = 3: dCount = 0 For Each tmp In ColA tbl = tmp.Value If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tbl CrWS.Cells(début, 5).Value = tbl dict.Remove tbl: début = début + 1: dCount = dCount + 1 End If Next tmp ColE = Application.WorksheetFunction.Max(début, CrWS.Cells(Rows.Count, 5).End(xlUp).Row + 1) UniCount = 0 For Each Key In dict.Keys CrWS.Cells(ColE, 5).Value = Key ColE = ColE + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit On Error Resume Next CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count).FormatConditions.Delete On Error GoTo 0 With CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count) .FormatConditions.Add Type:=xlExpression, _ Formula1:="=AND(D3<>"""", COUNTIF($D$3:$E$" & .Rows.Count & ", D3)>1)" .FormatConditions(1).Font.Color = RGB(255, 0, 0): .FormatConditions(1).Interior.Color = RGB(255, 182, 193) End With Irow = Application.WorksheetFunction.Max( _ CrWS.Cells(CrWS.Rows.Count, "D").End(xlUp).Row, CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row) a = CrWS.Range("D3:D" & Irow).Value: b = CrWS.Range("E3:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then With CrWS.Cells(i + 2, 4).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If If b(i, 1) <> "" Then With CrWS.Cells(i + 2, 5).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If Next i With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v4.xlsb

يمكننا أخي تعديل الكود ليتناسب مع طلبك لاكن لاحظت انه هناك أسماء متشابهة الفرق الوحيد بينها هو المسافات كما في المثال الموضح في الصورة أسفله إدا كنت تعتبر أنها أسماء متشابهة يجب جلبها أمام بعضها البعض فالكود التالي ربما سيوفي بالغرض Option Explicit Sub Extract_Names() Dim dCount As Long, UniCount As Long, AutoFilterWasOn As Boolean Dim Ons As Object, tbl As String, dict As Object, _ début As Long, lr As Long, tmp As Range, Key As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare Set Ons = CreateObject("Scripting.Dictionary") Ons.CompareMode = vbTextCompare For Each tmp In CrWS.Range("B3:B" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If Not dict.exists(tbl) Then dict.Add tbl, tmp.Row If Not Ons.exists(tbl) Then Ons.Add tbl, tmp.Row End If Next tmp CrWS.Range("D2:E" & CrWS.Rows.Count).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In CrWS.Range("A3:A" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tmp.Value CrWS.Cells(début, 5).Value = CrWS.Cells(dict(tbl), 2).Value dict.Remove tbl: Ons.Remove tbl: début = début + 1: dCount = dCount + 1 End If End If Next tmp For Each Key In Ons.keys CrWS.Cells(début, 5).Value = CrWS.Cells(Ons(Key), 2).Value début = début + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @M.Elmahmoudy رغم أن طلبك غير واضح تماما بالنسبة لي لاكن بعد معاينة الملف على حسب ما فهمت أعتقد أن الحل الأمثل لتنفيد طلبك هو إستخدام الأكواد لأنها سوف تضمن لك الدقة في النتائج والسرعة في التنفيد لأن المعادلات غير قادرة على تنفيذ جميع الوظائف بنفس الكفاءة خصوصا عند التعامل مع قوائم غير مرتبة وتكرار القيم ونطاقات غير المتساوية ولا ربما صفوف مخفية عند تنفيد الفرز على عمود معين زيادة على بطئ ملحوظ في الأداء عند وجود بيانات كبيرة يمكنك تجربة هدا وإذا كنت بحاجة إلى أي تعديلات إضافية يمكنني محاولة مساعدتك في ذلك Option Explicit Sub Extract_Names() Dim dict As Object, début As Long, lr As Long, tmp As Range, AutoFilterWasOn As Boolean Dim dCount As Long, UniCount As Long, ColA As Range, ColB As Range Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB If Not dict.exists(tmp.Value) Then dict.Add tmp.Value, tmp.Row Next tmp CrWS.Range("C2:C" & CrWS.Cells(CrWS.Rows.Count, 3).End(xlUp).Row).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In ColA If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value & " / " & CrWS.Cells(dict(tmp.Value), 2).Value dict.Remove tmp.Value début = début + 1 dCount = dCount + 1 End If Next tmp For Each tmp In ColB If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value début = début + 1 UniCount = UniCount + 1 End If Next tmp CrWS.Range("C2").Value = " عدد الوظائف / المتشابهة: " & dCount & " & الفردية: " & UniCount CrWS.Columns("C:C").EntireColumn.AutoFit Set dict = Nothing With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Book2 v2.xlsb

Dim Sh As Boolean Public Property Get f() As Worksheet Set f = Sheets("Sheet1") <========= إسم ورقة العمل المرغوب جلب إسم المصنف الجديد منها End Property Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS HideBar Me End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer, WBname As String WBname = f.[R2].Value <======= قم بتعديل عنوان خلية الإسم بما يناسبك If WBname = "" Then: MsgBox "الرجاء إدخال إسم المصنف ", vbExclamation, "إنتباه": Exit Sub 'Code........ .............. End Sub Private Sub CommandButton2_Click() On Error GoTo SupApp Dim arr As New Collection, TempWb As Workbook, WS As Worksheet Dim i As Integer, sMsg As Integer, tbl As Boolean Dim WBname As String, sPath As String, shArr As String WBname = Trim(f.Range("R2").Value) If WBname = "" Then MsgBox "الرجاء إدخال اسم المصنف", vbExclamation, "تنبيه": Exit Sub tbl = Me.CheckBox1.Value For i = 0 To Me.ListBox1.ListCount - 1 If tbl Or Me.ListBox1.Selected(i) Then arr.Add Me.ListBox1.List(i) shArr = shArr & Me.ListBox1.List(i) & "- " sMsg = sMsg + 1 End If Next If sMsg = 0 Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "تنبيه": Exit Sub If Len(shArr) > 0 Then shArr = Left(shArr, Len(shArr) - 2) End If If MsgBox("هل أنت متأكد أنك تريد حفظ الأوراق التالية؟" & _ vbNewLine & vbNewLine & shArr, vbYesNo + vbQuestion, "PDF" & " تأكيد الحفظ") = vbNo Then Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Set TempWb = Workbooks.Add(xlWBATWorksheet) For i = 1 To arr.Count ThisWorkbook.Sheets(arr(i)).Copy After:=TempWb.Sheets(TempWb.Sheets.Count) Next sPath = ThisWorkbook.path & "\" & WBname & ".pdf" If Dir(sPath) <> "" Then Kill sPath TempWb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False TempWb.Close False MsgBox "تم حفظ الملفات بنجاح", vbInformation, "PDF حفظ" Unload Me CleanUp: With Application .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With Exit Sub SupApp: On Error Resume Next: If Not TempWb Is Nothing Then TempWb.Close False Resume CleanUp End Sub تصدير صفحات v3.xlsm

تفضل جرب هدا Dim Sh As Boolean ' إسم المصنف الجديد Private Const WBname As String = "المجمع.xlsx" Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer tmps = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then tmps = tmps + 1 Next i If tmps = 0 And Not CheckBox1.Value Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "إنتباه" Exit Sub End If Sh = True With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With If Sh Then Set newWb = CreateWb() sPath = ThisWorkbook.path & "\" & WBname SaveNewWorkbook newWb, sPath sCount = 0 If CheckBox1.Value Then For i = 0 To Me.ListBox1.ListCount - 1 ShName = Me.ListBox1.List(i) CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb shArr = shArr & ShName & vbNewLine sCount = sCount + 1 Next i Else For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then ShName = Me.ListBox1.List(i) CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb shArr = shArr & ShName & vbNewLine sCount = sCount + 1 End If Next i End If WSDelete newWb newWb.Save newWb.Close SaveChanges:=True With Application .ScreenUpdating = True .EnableEvents = True .CopyObjectsWithCells = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With Unload Me MsgBox IIf(sCount = 1, "تم حفظ الورقة بنجاح", "تم حفظ الأوراق بنجاح") & vbNewLine & vbNewLine & shArr, vbInformation End If End Sub Private Function CreateWb() As Workbook Dim newWb As Workbook Set newWb = Workbooks.Add(xlWBATWorksheet) newWb.Sheets(1).name = "New" Set CreateWb = newWb End Function Private Sub SaveNewWorkbook(ByVal newWb As Workbook, ByVal filePath As String) On Error Resume Next newWb.SaveAs fileName:=filePath, FileFormat:=xlOpenXMLWorkbook On Error GoTo 0 End Sub Private Sub CopySheetToNewWorkbook(ByVal sourceSheet As Worksheet, ByVal targetWorkbook As Workbook) sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count) Dim WS As Worksheet Set WS = targetWorkbook.Sheets(targetWorkbook.Sheets.Count) WS.UsedRange.Value = WS.UsedRange.Value Application.CutCopyMode = False End Sub Private Sub WSDelete(ByVal newWb As Workbook) On Error Resume Next newWb.Sheets("New").Delete On Error GoTo 0 End Sub تصدير صفحات v2.xlsm

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

رغم أن هدا لم يكن طلبك في أول مشاركة لاكنني أعتقد أنه الان قد تم تزويدك بجميع الحلول الممكنة للحصول على النتائج المطلوبة تم وضع الصيغ في جدول مستقل لتتمكن من مقارنة النتائج صيغ الأعمدة G + H =LET(extracted_text, IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), NUMBERVALUE(IF(ISNUMBER(FIND(" ", extracted_text)), TRIM(LEFT(extracted_text, FIND(" ", extracted_text) - 1)), extracted_text))) أو =NUMBERVALUE(IF(ISNUMBER(FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2))), TRIM(LEFT(IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)) - 1)), IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)))) صيغ الأعمدة I + J =(IFERROR(VALUE("0 "&MID(F2,FIND(" ",F2)+1,LEN(F2)-FIND(" ",F2))), 0)) + (IFERROR(VALUE("0 "& IF(ISNUMBER(FIND(" ",G2)),TRIM(RIGHT(G2,LEN(G2)-FIND(" ",G2))), 0) ), 0)) بالتوفيق......... Sum Architect Units Feet-Inches V3.xlsx

العفو أخي يسعدنا أننا إستطعنا مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته Function NumtoTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim txtArr1(0 To 9) As String, txtArr2(0 To 9) As String, txtArr3(0 To 9) As String Dim Myno As String, GetNo As String, RdNo As String, My100 As String, I As Integer Dim My10 As String, My1 As String, My11 As String, My12 As String, GetTxt As String Dim MyAnd As String, Mybillion As String, MyMillion As String, MyThou As String Dim MyHun As String, MyFraction As String, ReMark As String If TheNo > 999999999999.999 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1: ReMark = "يتبقى لكم " Else ReMark = "" If TheNo = 0 Then NumtoTxt = "صفر": Exit Function MyAnd = " و" txtArr1(0) = "": txtArr1(1) = "مائة": txtArr1(2) = "مائتان": txtArr1(3) = "ثلاثمائة": txtArr1(4) = "أربعمائة" txtArr1(5) = "خمسمائة": txtArr1(6) = "ستمائة": txtArr1(7) = "سبعمائة": txtArr1(8) = "ثمانمائة": txtArr1(9) = "تسعمائة" txtArr2(0) = "": txtArr2(1) = "عشر": txtArr2(2) = "عشرون": txtArr2(3) = "ثلاثون": txtArr2(4) = "أربعون" txtArr2(5) = "خمسون": txtArr2(6) = "ستون": txtArr2(7) = "سبعون": txtArr2(8) = "ثمانون": txtArr2(9) = "تسعون" txtArr3(0) = "": txtArr3(1) = "واحد": txtArr3(2) = "اثنان": txtArr3(3) = "ثلاثة": txtArr3(4) = "أربعة" txtArr3(5) = "خمسة": txtArr3(6) = "ستة": txtArr3(7) = "سبعة": txtArr3(8) = "ثمانية": txtArr3(9) = "تسعة" GetNo = Format(TheNo, "000000000000.000") I = 0 Do While I < 15 If I < 12 Then Myno = Mid$(GetNo, I + 1, 3) ElseIf I = 12 Then Myno = Mid$(GetNo, I + 2, 3) End If If Val(Myno) > 0 Then RdNo = Mid$(Myno, 1, 1): My100 = txtArr1(Val(RdNo)) RdNo = Mid$(Myno, 3, 1): My1 = txtArr3(Val(RdNo)) RdNo = Mid$(Myno, 2, 1): My10 = txtArr2(Val(RdNo)) If Mid$(Myno, 2, 2) = "11" Then My11 = "إحدى عشر" If Mid$(Myno, 2, 2) = "12" Then My12 = "اثنا عشر" If Mid$(Myno, 2, 2) = "10" Then My10 = "عشرة" If Val(Mid$(Myno, 1, 1)) > 0 And Val(Mid$(Myno, 2, 2)) > 0 Then My100 = My100 + MyAnd If Val(Mid$(Myno, 3, 1)) > 0 And Val(Mid$(Myno, 2, 1)) > 1 Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If Val(Mid$(Myno, 3, 1)) = 1 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My11: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My11 End If If Val(Mid$(Myno, 3, 1)) = 2 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My12: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My12 End If If I = 0 And GetTxt <> "" Then If Val(Myno) > 10 Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If Val(Myno) = 1 Then Mybillion = "مليار" If Val(Myno) = 2 Then Mybillion = "ملياران" End If If I = 3 And GetTxt <> "" Then If Val(Myno) > 10 Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If Val(Myno) = 1 Then MyMillion = "مليون" If Val(Myno) = 2 Then MyMillion = "مليونان" End If If I = 6 And GetTxt <> "" Then If Val(Myno) > 10 Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If Val(Mid$(Myno, 3, 1)) = 1 Then MyThou = "ألف" If Val(Mid$(Myno, 3, 1)) = 2 Then MyThou = "ألفان" End If If I = 9 And GetTxt <> "" Then MyHun = GetTxt If I = 12 And GetTxt <> "" Then MyFraction = GetTxt End If I = I + 3 Loop If Mybillion <> "" Then If MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then Mybillion = Mybillion + MyAnd If MyMillion <> "" Then If MyThou <> "" Or MyHun <> "" Then MyMillion = MyMillion + MyAnd If MyThou <> "" Then If MyHun <> "" Then MyThou = MyThou + MyAnd If MyFraction <> "" Then If Mybillion <> "" Or MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur & MyAnd & MyFraction & " " & MySubCur Else NumtoTxt = ReMark & MyFraction & " " & MySubCur End If Else NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur End If End Function تعديل المبلغ - فلس V2.xlsm

جرب هدا هل يناسبك =SUM(IF(ISNUMBER(FIND("-",E2:E6)),LEFT(E2:E6,FIND("-",E2:E6)-1) + MID(E2:E6,FIND("-",E2:E6)+1,FIND (" ",E2:E6&" ")-FIND("-",E2:E6)-1)/12 + IFERROR(VALUE("0 "&MID(E2:E6,FIND(" ",E2:E6&" ")+1,LEN(E2:E6)))/12,0),E2:E6/12 )) Sum Architect Units Feet-Inches V2.xlsx

لقد تم الإعتماد مسبقا على الكود الأول والدي كان يتضمن وضع الفواصل بعد كلمة Sum تفضل أخي تم تعديل الكود ليتناسب مع طلبك لحفظ الصفحات في مجلد في نفس مسار المصنف بصيغة PDF جرب هدا Option Explicit Sub Save_PDF() On Error GoTo SupApp Dim WS As Worksheet, sPath As String, sFolder As String Dim count As Long, lastRow As Long, cell As Range, début As Integer Set WS = Sheets("test") lastRow = WS.Cells(WS.Rows.count, "B").End(xlUp).Row début = 1: count = 0 For Each cell In WS.Range("B2:B" & lastRow) If InStr(cell.Value, "المجموع") > 0 Then count = count + 1 Next cell If count > 0 Then If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & count & "؟", _ vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub sFolder = ThisWorkbook.Path & "\ملفات PDF" If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder sPath = sFolder & "\" & "Page_" & début & "-" & count & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End If SupApp: Set WS = Nothing End Sub تحديد عدد صفوف للصفحة ومجموعها -v3.xlsm للتنفيد على مصنف خارجي.rar Test PDF.pdf

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

وعليكم السلام ورحمة الله تعالى وبركاته للتنفيد على المصنف الخارجي معاهد ورقة معهد Public Property Get f() As Worksheet: Set f = ThisWorkbook.Sheets("test"): End Property Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "معاهد.xlsm" wsName = "معهد" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property Sub Split_Rows() Dim xColor As Long: xColor = RGB(204, 255, 204) Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long, TotalSum As Double Dim k As Integer, Irow As Integer, r As Long, count As Long, tbl As Double, j As Double Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub k = f.Range("G1").Value If k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i LastRow = .Cells(.Rows.count, "A").End(xlUp).Row StartRow = 2 tbl = 0 TotalSum = 0 i = StartRow Do While i <= LastRow EndRow = i + k - 1 If EndRow > LastRow Then EndRow = LastRow j = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow)) TotalSum = TotalSum + j If EndRow < LastRow Then .Rows(EndRow + 1).Insert Shift:=xlDown .Cells(EndRow + 1, "B").Value = SumRng .Cells(EndRow + 1, "E").Value = j + tbl .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor .Rows(EndRow + 2).Insert Shift:=xlDown .Cells(EndRow + 2, "B").Value = ColArr .Cells(EndRow + 2, "E").Value = j + tbl .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor tbl = j + tbl LastRow = LastRow + 2 End If i = EndRow + 3 Loop Irow = .Cells(.Rows.count, "A").End(xlUp).Row .Rows(Irow + 1).Insert Shift:=xlDown With .Cells(Irow + 1, "B") .Value = SumPages .Offset(0, 3).Value = TotalSum .Resize(1, 4).Font.Size = 18 .Parent.Range("A" & Irow + 1 & ":E" & Irow + 1).Interior.Color = xColor End With .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _ .Cells(r, 2).Value <> SumPages Then .Cells(r, 1).Value = count + 1 count = count + 1 End If Next r End With If Not CrWS Is Nothing Then Call PrintArea_data(CrWS) End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub '============================================ Sub déleteRows() Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" Dim LastRow As Long, i As Long If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub Application.ScreenUpdating = False With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i End With Application.ScreenUpdating = True End Sub '==================================== Sub PrintArea_data(CrWS As Worksheet) Dim rCount As Long, tmps As Long, i As Long Dim lastCol As Long, OnRng As Range, n As Long n = f.Range("G1").Value + 2 If n <= 0 Then Exit Sub tmps = 2 CrWS.ResetAllPageBreaks rCount = CrWS.Cells(CrWS.Rows.count, 2).End(xlUp).Row If rCount > tmps + n Then For i = tmps + n To rCount Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(1, "E").Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, 1), CrWS.Cells(rCount, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) With CrWS.PageSetup .Orientation = xlPortrait .PaperSize = xlPaperA4 .FitToPagesWide = 1 .FitToPagesTall = False End With End Sub وللتنفيد على نفس المصنف ورقة test Public Property Get CrWS() As Worksheet: Set CrWS = Sheets("test"): End Property Sub Split_Rows() Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" Dim xColor As Long: xColor = RGB(204, 255, 204) Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long Dim k As Integer, j As Integer, r As Long, count As Long Dim tbl As Double, TotalSum As Double, Irow As Double k = CrWS.Range("G1").Value If CrWS.Name <> "test" Or k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i LastRow = .Cells(.Rows.count, "A").End(xlUp).Row StartRow = 2 tbl = 0 TotalSum = 0 i = StartRow Do While i <= LastRow EndRow = i + k - 1 If EndRow > LastRow Then EndRow = LastRow Irow = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow)) TotalSum = TotalSum + Irow If EndRow < LastRow Then .Rows(EndRow + 1).Insert Shift:=xlDown .Cells(EndRow + 1, "B").Value = SumRng .Cells(EndRow + 1, "E").Value = Irow + tbl .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor .Rows(EndRow + 2).Insert Shift:=xlDown .Cells(EndRow + 2, "B").Value = ColArr .Cells(EndRow + 2, "E").Value = Irow + tbl .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor tbl = Irow + tbl LastRow = LastRow + 2 End If i = EndRow + 3 Loop j = .Cells(.Rows.count, "A").End(xlUp).Row .Rows(j + 1).Insert Shift:=xlDown With .Cells(j + 1, "B") .Value = SumPages .Offset(0, 3).Value = TotalSum .Resize(1, 4).Font.Size = 18 .Parent.Range("A" & j + 1 & ":E" & j + 1).Interior.Color = xColor End With .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _ .Cells(r, 2).Value <> SumPages Then .Cells(r, 1).Value = count + 1 count = count + 1 End If Next r End With Call PrintArea_data .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub للتنفيد على مصنف خارجي.rar تحديد عدد صفوف للصفحة ومجموعها v2.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته إدن لنجرب هدا الخلية N6 ="الالتزام "&INDEX({"الأول","الثاني","الثالث","الرابع","الخامس","السادس"}, ROW(A1)) الخلية L6 =IFERROR(INDEX($E$8:$E$367, MATCH(0, COUNTIF($L$5:L5, $E$8:$E$367), 0)), 0) الخلية K6 =IF(L6=0, 0, IF(L6<>"", COUNTIFS($E$8:$E$367, L6, $E$8:$E$367, "<>"), "0")) مع سحب المعادلات للأسفل Book2-V3.xlsx