محمد هشام.

تفضل أخي 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

نعم لان الاسماء لديك كلها تتضمن مسافة فارغة بين الاسماء كلية التربية كلية الاداره والاقتصاد قسم المحاسبة

ما هو الفرق بين الخلية الفارغة والخلية التي تحتوي على فراغ بالنسبة لك

هناك شيئ غير مفهوم يرجى ارفاق عينة للبيانات مع شكل النتائج المتوقعة بعد تنفيد الكود

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

الكود الدي أشرت إليه دوره هو نسخ القيم من عمود B و نسخها الى عمود XFD وازالة التكرارات منه ثم تعيين مصدر بيانات الكومبوبوكس من نفس العمود وهو ما تم استبداله بطريقة متقدمة نوعا ما على الشكل التالي دون الحاجة للنسخ واللصق For Each c In CrWS.Range("B2:B" & lastRow) If c.Value <> "" Then Tbl.Item(c.Value) = c.Value Next c End If If Tbl.Count > 0 Then temp = Tbl.Items Me.ComboBox1.List = temp لست مـتأكدا مما تحاول فعله لاكن إدا كنت تقصد أنك تريد حدف الصفوف الفارغة عند إختيارك فراغ من الكومبوبوكس جرب هدا التعديل Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "كلية.xlsb" wsName = "قسم" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property 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) Tbl.Item(c.Value) = c.Value 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 Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String 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 CrWS.Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=ky On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True UserForm_Initialize End If Else 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 i = lastRow To 2 Step -1 If IsEmpty(CrWS.Cells(i, "B").Value) Then CrWS.Rows(i).Delete Next i Application.ScreenUpdating = True UserForm_Initialize End If End If End Sub إما بخصوص تنفيد الكود على نفس المصنف الأخير تعديل صفوف الكلمات المختاره او صفوف الخلايا الفارغة عند اختيارها.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "كلية.xlsb" wsName = "قسم" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property 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 c.Value <> "" Then Tbl.Item(c.Value) = c.Value 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 Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String 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 With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=ky End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True ' اختار ما يناسبك UserForm_Initialize 'OR ' Unload Me End If End If End Sub TEST.zip

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub SaveAsPDF() Dim CrWS As Worksheet: Set CrWS = Sheets("بيانات") Dim lastRow As Long: lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row Dim xPath As String: xPath = ThisWorkbook.Path & "\كشف_التلاميذ.pdf" CrWS.Range("A2:J" & lastRow).ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub test() Dim ws As Worksheet: Set ws = Sheets("توزيع") Dim RowDest As Long: RowDest = 1 Dim Irow As Long, tmp As Long, ky As String Application.ScreenUpdating = False ws.Range("L1:L" & ws.Rows.Count).ClearContents For Irow = 7 To ws.Cells(ws.Rows.Count, "G").End(xlUp).Row ky = ws.Cells(Irow, "G").Value If ky <> "" Then tmp = IIf(ky = "آداب و فلسفة", 7, _ IIf(ky = "لغات أجنبية - إسبانية" Or ky = "لغات أجنبية - ألمانية", 8, 9)) For tmp = 1 To tmp ws.Cells(RowDest, 12).Value = ky & tmp RowDest = RowDest + 1 Next tmp End If Next Irow Application.ScreenUpdating = True End Sub Classeur2 v2.xlsm

جرب هدا =IFERROR(INDEX($G$7:$G$19;MATCH(TRUE;MMULT(--(ROW($G$7:$G$19)>=TRANSPOSE(ROW($G$7:$G$19)));$H$7:$H$19)>=ROWS($6:6);0));"")

وعليكم السلام ورحمة الله تعالى وبركاته بالنسبة للكود المقدم لك مسبقا يمكنك تعديله على الشكل التالي Private Sub CommandButton16_Click() Dim Tmam_Wbk As Workbook, TPath As String If ComboBox28.Value = "" Then MsgBox "من فضلك أختار التجهيزة": Exit Sub If OptionButton1.Value Then TPath = ThisWorkbook.Path & "\تمام\مدينة\" & ComboBox28.Value ElseIf OptionButton2.Value Then TPath = ThisWorkbook.Path & "\تمام\محافظات\" & ComboBox28.Value End If If Len(Dir(TPath & ".xlsx")) > 0 Then TPath = TPath & ".xlsx" ElseIf Len(Dir(TPath & ".xls")) > 0 Then TPath = TPath & ".xls" Else MsgBox "الملف غير موجود": Exit Sub End If On Error GoTo ErrorHandler Set Tmam_Wbk = Workbooks.Open(TPath) Unload Me Exit Sub ErrorHandler: Unload Me End Sub هنا قمت بتعديل الامتدادات على عدة أكواد للتجربة Run V3.xls

وعليكم السلام ورحمة الله تعاللى وبركاته أخي @Mharee Accounting Albaig يفضل دائما إلغاء باسوورد محرر الأكواد قبل رفع الملف لتفادي إهدار الوقت في كسره جرب هدا Private Sub CommandButton1_Click() On Error GoTo ErrorHandler Dim xlSheet As Worksheet, xlSh As Worksheet, crWS As Worksheet Dim Sht As Worksheet, B As VbMsgBoxResult, T As Long, i As Long, LastCol As Long Set Sht = ThisWorkbook.Sheets("كشف") Set crWS = ThisWorkbook.Sheets("الناسخة ") If Me.BackColor = 192 Or TextBox1.Text = "" Then MsgBox IIf(Me.BackColor = 192, "الاسم مرفوض نصياً", "خلايا فارغة"), vbInformation + vbMsgBoxRight, "تنبيه" Exit Sub End If For Each xlSh In ThisWorkbook.Worksheets If xlSh.Name = Trim(TextBox1.Text) Then MsgBox "اسم مكرر", vbInformation + vbMsgBoxRight, "تنبيه": Exit Sub Next xlSh B = MsgBox("هل تريد اضافة" & vbNewLine & vbNewLine & "الحساب: " & _ TextBox1.Text, vbOKCancel + vbQuestion + vbMsgBoxRight, "تأكيد اضافة حساب") If B = vbCancel Then Exit Sub Application.ScreenUpdating = False Set xlSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) With xlSheet .Name = TextBox1.Text crWS.Range("A1:R74").Copy .Cells.PasteSpecial Paste:=xlPasteAllUsingSourceTheme .Cells.PasteSpecial Paste:=xlPasteColumnWidths ActiveSheet.DisplayRightToLeft = True LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column If LastCol > 18 Then LastCol = 18 .Range(.Cells(1, 1), .Cells(1, LastCol)).AutoFilter .PageSetup.LeftHeader = "كشف حساب " & TextBox1.Text .PageSetup.RightHeader = "اسم الشركة: Bina Puri sdn Bhd" With ActiveWindow .FreezePanes = True .DisplayGridlines = False End With xlSheet.Range("A1").Select End With T = Sht.Range("B" & Sht.Rows.Count).End(xlUp).Row + 1 For i = 1 To ThisWorkbook.Sheets.Count If ThisWorkbook.Sheets(i).Name <> Sht.Name And ThisWorkbook.Sheets(i).Name <> crWS.Name Then Sht.Range("B" & T) = ThisWorkbook.Sheets(i).Name T = T + 1 End If Next i Cleanup: Application.ScreenUpdating = True Set xlSheet = Nothing Set Sht = Nothing Exit Sub ErrorHandler: Resume Cleanup End Sub ورقة بالفلتر.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته الكود الخاص بك يستخدم Application.FileSearch والذي كان مدعوما في Excel 2003 ولكن تم إيقاف دعمه في الإصدارات الأحدث من Excel أعتقد مند 2007 وبالتالي يتطلب تعديلات ليعمل على الإصدارات الأحدث جرب هدا Private Sub TamamUpdate() Dim val As String, Namey As String, file As String ComboBox28.Clear If OptionButton1.Value = True Then val = ThisWorkbook.Path & "\تمام\مدينة\" ElseIf OptionButton2.Value = True Then val = ThisWorkbook.Path & "\تمام\أكثر\" End If file = Dir(val & "*.xls*") Do While file <> "" Namey = Left(file, InStrRev(file, ".") - 1) ComboBox28.AddItem Namey file = Dir Loop End Sub بطريقة أخرى الكود التالي يؤدي نفس المهمة ولكنه يوفر للمستخدم خيار تحديد المجلد الذي سيتم البحث فيه الكود الخاص بك كان يعتمد على اختيار المجلد بناء على الاختيارات OptionButton1 و OptionButton2 بينما هذا الكود يسمح للمستخدم بتحديد المجلد يدويا باستخدام FileDialog Private Sub TamamUpdate() Dim val As String, Namey As String Dim fd As FileDialog, tmps As String Set fd = Application.FileDialog(msoFileDialogFolderPicker) If fd.Show = -1 Then tmps = fd.SelectedItems(1) Else Exit Sub End If ComboBox28.Clear val = tmps & "\" file = Dir(val & "*.xls*") Do While file <> "" Namey = Left(file, InStrRev(file, ".") - 1) ComboBox28.AddItem Namey file = Dir Loop End Sub RUN-v2.xls

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Dim tmps As Object, cell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If tmps Is Nothing Then Set tmps = CreateObject("Scripting.Dictionary") If Target.Cells.Count > 1 Then Exit Sub For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing Then tmps(cell.Address) = cell.Value Next cell ExitHandler: Exit Sub ClearApp: Set tmps = Nothing Resume ExitHandler End Sub Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Or tmps Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing And tmps.exists(cell.Address) Then If IsNumeric(cell.Value) Then cell.Value = tmps(cell.Address) + cell.Value Else MsgBox cell.Address & " : " & "تم إدخال قيمة غير صالحة في الخلية ", vbExclamation End If End If Next cell ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub جمع الخلية v3.xlsb

المفروض أن الكود التالي يشتغل معك Sub SortStudents() Dim WS As Worksheet Dim lastRow As Long Dim OnRng As Range Set WS = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Application.ScreenUpdating = True Exit Sub End If Set OnRng = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear .SortFields.Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .SortFields.Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending .SetRange OnRng .Header = xlYes .Apply End With Application.ScreenUpdating = True End Sub ترتيب الاوائل v3.xlsb

غريب الكود يشتغل معي بشكل جيد اليك حل اخر لاختيار ما يناسبك Option Explicit Sub SortArray() Dim a() As Variant, i As Long, j As Long, col As Long Dim temp As Variant, lastRow As Long, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row Set OnRng = WS.Range("A1:E" & lastRow) a = OnRng.Value For i = 2 To UBound(a, 1) - 1 For j = i + 1 To UBound(a, 1) If a(i, 3) < a(j, 3) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col ElseIf a(i, 3) = a(j, 3) Then If a(i, 4) > a(j, 4) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col ElseIf a(i, 4) = a(j, 4) Then If a(i, 5) > a(j, 5) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col End If End If End If Next j Next i OnRng.Value = a End Sub ترتيب الاوائل v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub StringSort() Dim WS As Worksheet, lastRow As Long Set WS = Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With WS.Sort .SortFields.Clear .SortFields.Add2 Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .SortFields.Add2 Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending .SortFields.Add2 Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending .SetRange WS.Range("A1:E" & lastRow) .Header = xlYes .Apply End With Application.ScreenUpdating = True End Sub