محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته في الجزء الأخير من الكود قم بإظافة هدا 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

إدا كنت ترغب في إستخدام الإقتراح المقدم من الأستاد @أبوعيد يمكنك تجربة هدا Public Property Get CrWS() As Worksheet Set CrWS = Sheets("ورقة1") End Property Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") 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 End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String If Me.ComboBox1.Value <> "" 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 Unload Me End If End Sub مسح صفوف معينة بناء على قيمتها v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim CrWS As Worksheet Dim lastRow As Long, tmps As Variant tmps = Array("=*كلية التربية*", "=*معهد عالي*") Set CrWS = Sheets("ورقة1") 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:=tmps, Operator:=xlFilterValues End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True End Sub

Sub Split_names() Dim WS As Worksheet, dest As Worksheet Dim tbl&, Max&, lr&, tmp&, i&, c&, j&, r&, s&, n As String, ky As Boolean Dim ColArr As Range, OnRng As Range, Arr As Variant, rng As Variant, sp As Variant Dim ColNam As String: ColNam = "DM" Set WS = Sheets("حساب الفوائد") Set dest = Sheets("مؤشر الفائدة") Max = 444 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error Resume Next tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max) WS.Range("DJ14:DJ" & tbl).ClearContents Set OnRng = WS.Range("T14:CC" & tbl) Arr = OnRng.Value For tmp = 1 To UBound(Arr, 1) n = "" ky = False For i = 1 To UBound(Arr, 2) If Arr(tmp, i) <> "" Then n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text) If Not ky Then WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat ky = True End If End If Next i WS.Cells(tmp + 13, 114).Value = n Next tmp On Error Resume Next Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not ColArr Is Nothing Then Arr = ColArr.Value ReDim rng(1 To UBound(Arr, 1), 1 To 1) For c = 1 To UBound(Arr, 1) rng(c, 1) = Arr(c, 1) Next c WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng End If dest.Range("AS2") = 2 dest.Range("I6:AL105").ClearContents lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value For j = 1 To UBound(Arr, 1) sp = Split(Arr(j, 1), "*") For r = LBound(sp) To UBound(sp) WS.Cells(j + 13, r + 118).NumberFormat = "@" WS.Cells(j + 13, r + 118).Value = sp(r) Next r Next j ColonnesVides dest, 9, 38 WS.Range("DN14:EQ113").SpecialCells(xlCellTypeVisible).Copy dest.Range("I6:AL105").PasteSpecial xlPasteValues AutoFitColumns dest, 9, 38 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub Sub ColonnesVides(sh As Worksheet, début As Integer, FinCol As Integer) Dim s As Integer For s = début To FinCol sh.Columns(s).EntireColumn.Hidden = (sh.Cells(5, s).Value = "") Next s End Sub Sub AutoFitColumns(sh As Worksheet, début As Integer, FinCol As Integer) Dim s As Integer For s = début To FinCol sh.Columns(s).AutoFit Next s End Sub بالتوفيق.............

جرب هل هدا ما تقصده Option Explicit Sub Split_names() Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s& Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range Dim Arr As Variant, rng As Variant, sp As Variant, Choisir As VbMsgBoxResult Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد") Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة") Dim ColNam As String: ColNam = "DM" Choisir = MsgBox("تحديث البيانات ؟", vbYesNo + vbQuestion, "تأكيد") If Choisir <> vbYes Then Exit Sub Max = 444 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error Resume Next tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max) WS.Range("DJ14:DJ" & tbl).ClearContents Set OnRng = WS.Range("T14:CC" & tbl) Arr = OnRng.Value For tmp = 1 To UBound(Arr, 1) n = "" ky = False For i = 1 To UBound(Arr, 2) If Arr(tmp, i) <> "" Then n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text) If Not ky Then WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat ky = True End If End If Next i WS.Cells(tmp + 13, 114).Value = n Next tmp On Error Resume Next Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not ColArr Is Nothing Then Arr = ColArr.Value ReDim rng(1 To UBound(Arr, 1), 1 To 1) For c = 1 To UBound(Arr, 1) rng(c, 1) = Arr(c, 1) Next c WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng End If dest.Range("AS2") = 2 dest.Range("I6:AL105").ClearContents lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value For j = 1 To UBound(Arr, 1) sp = Split(Arr(j, 1), "*") For r = LBound(sp) To UBound(sp) WS.Cells(j + 13, r + 118).NumberFormat = "@" WS.Cells(j + 13, r + 118).Value = sp(r) Next r Next j For s = 9 To 38 dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0) Next s With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub نسب ومؤشر الفائدة v4.xlsb

ليس لي فكرة عما تحاول فعله بالظبط لاكن اليك الكود مرة أخرى بعد تعديل أسماء الأعمدة المستهدفة بما يتناسب مع شكل الملف الأصلي إعتمادا على الصورة المرفقة حاول تجربته ووافينا بالنتيجة Option Explicit Sub test() Dim sp As Variant, j As Long, lr As Long, i As Long Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد") Dim ColNam As String: ColNam = "DM" Dim destCol As String: destCol = "DN" With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error GoTo CleanUp lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row If lr >= 14 Then WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents For j = 14 To lr If Not IsEmpty(WS.Cells(j, ColNam).Value) Then sp = Split(WS.Cells(j, ColNam).Value2, "*") For i = LBound(sp) To UBound(sp) WS.Range(destCol & j).Offset(0, i).NumberFormat = "@" WS.Range(destCol & j).Offset(0, i).Value = sp(i) Next i End If Next j End If CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub فصل كلمات وأرقام v3.xlsb

وعليكم السلام ورحمة الله تعاى وبركاته اقتراح اخر Option Explicit Sub test() Dim lastRow, i As Long, OnRng, tmp, key As Variant Dim name As String, amount As Double, dict As Object Dim WS As Worksheet: Set WS = Sheets("ورقة1") With WS lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Exit Sub Set dict = CreateObject("Scripting.Dictionary"): OnRng = .Range("B2:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) name = Trim(OnRng(i, 1)): amount = OnRng(i, 2): If name <> "" Then dict(name) = dict(name) + amount Next i Application.ScreenUpdating = False .Range("E2:F" & lastRow).ClearContents If dict.Count = 0 Then: Exit Sub ReDim tmp(1 To dict.Count, 1 To 2) i = 1 For Each key In dict.keys tmp(i, 1) = key: tmp(i, 2) = dict(key): i = i + 1 Next key .Range("E2").Resize(dict.Count, 2).Value = tmp Application.ScreenUpdating = True End With End Sub