محمد هشام.

تفضل جرب هدا 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

بما أن الكود المقترح لا يشتغل معك أظن أن طلبك غير واضح بالنسبة لي

الكود يتم تنفيده على الورقة النشطة Dim WS As Worksheet: Set WS = ActiveSheet لتحديد ورقة معينة قم باستبداله على الشكل التالي Dim WS As Worksheet: Set WS = Sheets("Sheet1") 'اسم ورقة العمل

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub ResetColumns() Dim lr&, i& Dim WS As Worksheet: Set WS = ActiveSheet lr = 15 'WS.Columns("A:B").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 3 To lr WS.Range(WS.Cells(i, 1), WS.Cells(i, 2)).Value = 0 Next i End Sub 1919.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته في Module Option Explicit Sub Filtre() Dim tbl() As Variant, rng As Variant Dim desWS As Worksheet, WS As Worksheet Dim i As Long, j As Long, tmp As Long Set WS = Sheets("ورقة2") Set desWS = Sheets("ورقة1") Application.ScreenUpdating = False desWS.Range("A2:D" & desWS.Rows.Count).ClearContents rng = WS.Range("A2:D" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim tbl(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 1) <> "" And rng(i, 4) > 0 Then tmp = tmp + 1 For j = 1 To UBound(rng, 2) tbl(tmp, j) = rng(i, j) Next j End If Next i If tmp > 0 Then desWS.Range("A2").Resize(tmp, UBound(tbl, 2)).Value = tbl Application.ScreenUpdating = True End Sub وفي حدث ورقة1 Private Sub Worksheet_Activate() Call Filtre End Sub مثال.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يرجى ارفاق عينة للنتائج المتوقعة مثلا ماهي قيمة Total Length (Ft) للبيانات الحالية

تفضل أخي Private Const sFolder As String = "الكشوفات PDF" Private Const NamePDF As String = "كشف مناداة" Private Const CrWS As String = "لجان 4" Private Const Logo As String = "IMG" Sub Copy_SavePDFfinal() Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, img As Shape, r As Shape Dim lastRow As Long, Rng As Range, OnRng As Range Dim f As Worksheet: Set f = Sheets(CrWS) If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub début = f.[B1].Value: fin = f.[S2].Value Set OnRng = f.Range("B2:O45") If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", _ vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Set WS = Sheets("PDF") If WS Is Nothing Then Sheets.Add.Name = "PDF" Set WS = Sheets("PDF") WS.DisplayRightToLeft = True End If On Error GoTo 0 tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[B1].Value = i lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).row If WS.Cells(2, 3).Value = "" Then Set Rng = WS.Range("B" & lastRow + 1) Else lastRow = WS.Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set Rng = WS.Range("B" & lastRow + 5) End If OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths WS.Cells.NumberFormat = "0;-0;;@" On Error Resume Next Set img = f.Shapes(Logo) If Not img Is Nothing Then img.Copy WS.Paste Destination:=WS.Cells(Rng.row - 1, "F") Set img = WS.Shapes(Logo) img.Top = img.Top If img.Left + img.Width > WS.Range("O1").Left Then img.Left = WS.Range("O1").Left - img.Width End If If img.Top + img.Height > WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top Then img.Top = WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top - img.Height End If End If On Error GoTo 0 For row = 1 To OnRng.Rows.Count WS.Rows(Rng.row + row - 1).RowHeight = OnRng.Rows(row).RowHeight Next row WS.HPageBreaks.Add Before:=WS.Cells(Rng.row + OnRng.Rows.Count, 1) With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .CenterHorizontally = True End With Application.CutCopyMode = False Next i sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 f.[B1].Value = 1 WS.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح", vbInformation End Sub المصنف v3.xlsb

إدن لنجرب هدا 1) إظهار جميع القيم الموجودة بالعمود سواءا رقمية أو نصية وكدالك الفراغات بعد تمييزها بكلمة فارغة 2) عند اختيار قيمة معينة من عنصر الكومبوبوكس سواءا نصية أو رقمية سيتم حدف الصفوف التي تتضمن القيمة المحددة 3) لجدف الصفوف الفارغة قم بتحديد كلمة فارغة من عنصر كومبوبوكس 1 4) تمت إظافة دالة لترتيب القيم أبجديا على عنصر كومبوبوكس1 لتسهيل العثور على القيمة المطلوبة 5) تم إظافة إعادة ترقيم البيانات على عمود A عند الحدف في حالة كنت بحاجة لدالك Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If Trim(c.Value) <> "" Then Tbl.Item(c.Value) = c.Value End If Next c End If If Application.WorksheetFunction.CountBlank(CrWS.Range("B2:B" & lastRow)) > 0 Then Tbl.Item("فارغة") = "فارغة" End If If Tbl.Count > 0 Then temp = Tbl.Items Call Tri(temp, LBound(temp), UBound(temp)) Me.ComboBox1.List = temp End If Else MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As Variant, c As Range, OnRng As Range If Me.ComboBox1.Value <> "" Then If Not CrWS Is Nothing Then ky = Me.ComboBox1.Value lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False If ky = "فارغة" Then For Each c In CrWS.Range("B2:B" & lastRow) If Trim(c.Value) = "" Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If Next c Else For Each c In CrWS.Range("B2:B" & lastRow) If IsNumeric(c.Value) And IsNumeric(ky) Then If CDbl(c.Value) = CDbl(ky) Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If Else If Trim(c.Value) = Trim(ky) Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If End If Next c End If If Not OnRng Is Nothing Then OnRng.Delete End If With CrWS.Range("A2:A" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With UserForm_Initialize Me.ComboBox1.Value = "" Application.ScreenUpdating = True End If End If End Sub Sub Tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call Tri(a, g, droi) If gauc < d Then Call Tri(a, gauc, d) End Sub وأي إستفسار أو تعديل سوف نكون سعداء دائما بحصولك على النتائج المطلوبة بالتوفيق ........ TEST 3.rar

سوف أحاول تنفيد الفكرة السابقة بإظافة ورقة مخفية لدمج الملفات وإعادة رفع الملف لاكن ربما يجب عليك تقليص عدد الصفوف على ورقة لجان 4 الى 44 لتتماشى مع تنسيق صفحات Pdf ادا لم يكن لديك مانع في دالك

1) للأسف طريقة إشتغالك على الملف لن تمكنك من حفظ جميع الملفات على ملف واحد PDF لاكن هناك حلول بديلة وهي إما دمجها يدويا من خلال برامج خارجية بعد الحفظ أو محاولة إظافة ورقة جديدة يتم نسخ الصفحات المطلوبة إليها تحت بعضها البعض وبالتالي تنسيق وحفظ الورقة في ملف مستقل وهدا يتطلب تعديل كود و طريقة الحفظ 2) مكان الحفظ الحالي هو مجلد في نفس مسار المصنف بإسم ملفات PDF 3) مسألة إرجاع قيمة الخلية F7 بعد الحفظ الى 1 يكفي في أخر الكود وضع f.[B1].Value = 1

أعتقد أن طلبك الأخير يختلف عما دكرت سابقا الطلب رقم 2 المطلوب عند اختيار من الكومبوبكس اي من الخلايا العمود b يقوم بمسح الصف باكمله فعندما تكون الخليه فارغة لا تظهر في الكومبوبكس لمسح الصف وكذلك عند اختيار خلية تحتوى على رقم لا يمسح الصف جرب هل هدا ما تقصده Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String, c As Range If Me.ComboBox1.Value <> "" Then If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False For Each c In CrWS.Range("B2:B" & lastRow) If c.Value = Me.ComboBox1.Value Then If Not IsNumeric(c.Value) And c.Value <> "" Then c.EntireRow.Delete End If End If Next c Application.ScreenUpdating = True UserForm_Initialize End If End If End Sub في حالة الرغبة لعدم إظهار القيم الرقمية والفارغة على الكومبوبوكس يمكنك تعديل كود جلب البيانات على الشكل التالي Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If Not IsNumeric(c.Value) And c.Value <> "" Then Tbl.Item(c.Value) = c.Value End If Next c End If If Tbl.Count > 0 Then temp = Tbl.Items Me.ComboBox1.List = temp End If Else MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation End If End Sub TEST 2.rar

وعليكم السلام ورحمة الله تعلى وبركاته جرب هدا بعد محاولة إلغاء دمج الخلايا على الجدول 2 Private Const début As Long = 7 Private Const StarRow As Long = 6 Sub Data_Extraction() Dim lastRow As Long, a As Long, i As Long, b As Long Dim tmp As Double, tbl As Double, arr As Variant, ky As Long arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس") Application.ScreenUpdating = False With Sheets("Sheet1") .Cells(6, 13).Resize(6, 3).ClearContents lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row a = StarRow b = début tmp = .Cells(b, 5).Value For i = b + 1 To lastRow + 1 tbl = .Cells(i, 5).Value If tbl <> tmp Or i = lastRow + 1 Then If tmp <> 0 Then ky = a - StarRow .Cells(a, 11).Value = i - b: .Cells(a, 12).Value = tmp .Cells(a, 13).Value = "الالتزام " & arr(ky) a = a + 1 End If b = i tmp = tbl End If Next i Do While a <= 11 ky = a - StarRow .Cells(a, 11).Value = 0: .Cells(a, 12).Value = 0 .Cells(a, 13).Value = "الالتزام " & arr(ky) a = a + 1 Loop End With Application.ScreenUpdating = True MsgBox "تم استخراج الأقساط والمدد بنجاح", vbInformation End Sub Book v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته في الجزء الأخير من الكود قم بإظافة هدا With crWS.PageSetup xlSheet.PageSetup.PaperSize = .PaperSize xlSheet.PageSetup.Orientation = .Orientation xlSheet.PageSetup.LeftMargin = .LeftMargin xlSheet.PageSetup.RightMargin = .RightMargin xlSheet.PageSetup.TopMargin = .TopMargin xlSheet.PageSetup.BottomMargin = .BottomMargin xlSheet.PageSetup.HeaderMargin = .HeaderMargin xlSheet.PageSetup.FooterMargin = .FooterMargin xlSheet.PageSetup.PrintArea = .PrintArea xlSheet.PageSetup.PrintTitleRows = .PrintTitleRows xlSheet.PageSetup.PrintTitleColumns = .PrintTitleColumns xlSheet.PageSetup.Zoom = .Zoom End With ActiveWindow.View = xlPageBreakPreview ActiveWindow.Zoom = 100 حدود طباعة ثابتة v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const sFolder As String = "ملفات PDF" Private Const CrWS As String = "لجان 4" Sub SavePDF() Dim f As Worksheet, début As Integer, fin As Integer, i As Integer Dim sPath As String, sName As String, tempFile As String Set f = Sheets(CrWS) If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub début = f.[B1].Value: fin = f.[S2].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub Application.ScreenUpdating = False tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[B1].Value = i sName = f.[F7].Value & IIf(f.[M7].Value <> "", " - " & f.[M7].Value, "") sPath = tempFile & "\" & "Page - " & sName & ".pdf" On Error Resume Next f.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح", vbInformation End Sub المصنف v2.xlsb

ادا كانت لديك اسماء متشابهة الفرق الوحيد بينها هي المسافات الفارغة وتريد حدف الاسماء التي تتضمن مسافات فقط أو العكس حاول نعديل هدا ky = "=*" & Me.ComboBox1.Value & "*" الى ky = Me.ComboBox1.Value