محمد هشام.

جرب هدا هل يناسبك =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