سليم حاصبيا

جرب هذا الملف (بدون يوزر فورم) انا شخصياً لا احب التعامل مع يوزر فورم و مشاكله sader.rar

تم معالجة الامر ترتيب2 Salim.rar

لا اعلم ما السبب عندك عندي يعمل بطريقة جيدة لتعديل الكود الى جدول اخر يجب تغيير my_rg الى عنوان النطاق الجديد لنفرض ان الجدول من D1 الى R50 يجب تغيير سطر set my_rg الى Set my_rg = Range("d1:r50") Aziz_salim1.rar

بعد اذن اخي بن علية هذه المعادلة (Ctrl+Shift+Enter) حتى بدون ترتيب الارقام =SUM(IF(S6<$S$6:$S$110,1/COUNTIF($S$6:$S$110,$S$6:$S$110)))+1 الملق مرفق ترتيب Salim.rar

جرب هذا الملف Aziz_salim.rar

دمج الخلايا المتشابهة مع خيار التراجع(مع ان التراجع عن امر نفذ بواسطة الماكرو مستحيل) لكن لا مستحيل في الـ VBA الماكرو Option Explicit Sub merg_cell() Application.ScreenUpdating = False Application.DisplayAlerts = False If ActiveSheet.Name <> "Salim" Then GoTo 1 Dim i%, my_rg As Range, k% i = 2 Do Until Cells(i, 1) = "" k = Application.CountIf(Range("a:a"), Cells(i, 1)) With Range(Cells(i, 1), Cells(i + k - 1, 1)) .Merge .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With i = i + k Loop 1: Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub Unmerge_Salim() Dim numrow, n As Long, t%, x%, k%, cc% Dim lrxfd%, y% If ActiveSheet.Name <> "Salim" Then Exit Sub On Error Resume Next n = 2 Do Until Range("a" & n) = vbNullString If Range("a" & n).MergeCells Then cc = 1: Exit Do n = n + 1 Loop If cc = 0 Then MsgBox "No Mergrd cells In this range": Exit Sub numrow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row Range("xfd:xfd").ClearContents k = 0 ' number of meged areas n = 2 ' begenning of loop Do Until Range("a" & n) = vbNullString If Range("a" & n).MergeCells Then t = Range("a" & n).MergeArea.Count Range("xfd" & n) = Range("a" & n) For x = 1 To t - 1 Range("xfd" & n).Offset(x, 0) = Range("xfd" & n) Next k = k + 1 Else t = 1 Range("xfd" & n) = Range("a" & n) End If n = n + t Loop lrxfd = Cells(Rows.Count, "xfd").End(3).Row Range("a:a").UnMerge Range("a2").Resize(lrxfd - 1).Value = Range("xfd2").Resize(lrxfd - 1).Value Range("xfd:xfd").ClearContents If k <> 0 Then MsgBox "There was :" & k & " merged Areas" End Sub Merge_Unmerge_cells.rar

من الضروري رفع جزء بسيط من الملف(حوالي 20 صف) لمعرفة الخطأ

جرب هذا الملف (نموذج) تم الاحتقاظ بالبيانات القديمة في الصفحة "Copy_Salim" لاعادة تجربة الماكرو قم اولاً بنسخ البيانات من صفحة"Copy_Salim" الى صفحة "Salim" الماكرة Option Explicit Sub merg_cell() Application.ScreenUpdating = False Application.DisplayAlerts = False If ActiveSheet.Name <> "Salim" Then GoTo 1 Dim i%, my_rg As Range, k% Range("a:a").UnMerge i = 2 Do Until Cells(i, 1) = "" k = Application.CountIf(Range("a:a"), Cells(i, 1)) Range(Cells(i, 1), Cells(i + k - 1, 1)).Merge Range(Cells(i, 1), Cells(i + k - 1, 1)).HorizontalAlignment = xlCenter Range(Cells(i, 1), Cells(i + k - 1, 1)).VerticalAlignment = xlCenter i = i + k Loop 1: Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الملف مرفق Merge_cells.rar

هذا الماكرو Option Explicit Sub Select_areas() Dim mY_rg As Range Dim last_col% Dim y% y = ActiveCell.Column Set mY_rg = Range("a2").CurrentRegion last_col = Cells(ActiveCell.Row, Columns.Count).End(1).Column With ActiveCell If last_col = 1 Then .Interior.ColorIndex = 6 .Borders.LineStyle = 1 Else .Offset(, -y + 1).Resize(, last_col).SpecialCells(2, 23).Interior.ColorIndex = 6 .Offset(, -y + 1).Resize(, last_col).SpecialCells(2, 23).Borders.LineStyle = 1 End If End With End Sub '=================================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False On Error Resume Next Dim rg As Range Set rg = Range("a2").CurrentRegion rg.Interior.ColorIndex = 0 rg.Borders.LineStyle = 0 If Target.Count > 1 Or Target = vbNullString Then GoTo 1 Select_areas 1: Application.EnableEvents = True On Error GoTo 0 End Sub '===================================================

الملف مع التعديل الملف مع التعديل Select_data_by_columns_1.rar

ت تغيير سطر واحد في الكود يقوم بهذا العمل Sub Select_areas() Dim mY_rg As Range Dim last_col% Set mY_rg = Range("a2").CurrentRegion mY_rg.Interior.ColorIndex = 0 last_col = Cells(ActiveCell.Row, Columns.Count).End(1).Column 'ActiveCell.Resize(, last_col).Interior.ColorIndex = 6 ActiveCell.Resize(, last_col).SpecialCells(xlCellTypeConstants, 23).Interior.ColorIndex = 6 End Sub '=================================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False On Error Resume Next Dim rg As Range Set rg = Range("a2").CurrentRegion rg.Interior.ColorIndex = 0 If Target.Column <> 1 Or Target.Count > 1 Or Target = vbNullString Then GoTo 1 Select_areas 1: Application.EnableEvents = True On Error GoTo 0 End Sub

اختي الفاضلة جربي هذا الملف (نموذج بسيط عما تريدينه) Select_data_by_columns.rar الكود فيما يعد لضعف النت الكود Sub Select_areas() Dim mY_rg As Range Dim last_col% Set mY_rg = Range("a2").CurrentRegion mY_rg.Interior.ColorIndex = 0 last_col = Cells(ActiveCell.Row, Columns.Count).End(1).Column ActiveCell.Resize(, last_col).Interior.ColorIndex = 6 End Sub '=================================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False On Error Resume Next Dim rg As Range Set rg = Range("a2").CurrentRegion rg.Interior.ColorIndex = 0 If Target.Column <> 1 Or Target.Count > 1 Or Target = vbNullString Then GoTo 1 Select_areas 1: Application.EnableEvents = True On Error GoTo 0 End Sub '

جرب هذا الماكرو Sub Del_Duplicates() Dim my_rg As Range Dim r%, t%, i% If ActiveSheet.Name <> "ورقة1" Then GoTo 1 Application.ScreenUpdating = False Set my_rg = Range("f21").CurrentRegion r = my_rg.Rows.Count Set my_rg = my_rg.Offset(1).Resize(r - 1) r = my_rg.Rows.Count On Error Resume Next my_rg.Columns(3).SpecialCells(4).EntireRow.Delete On Error GoTo 0 ActiveSheet.Range(my_rg.Address).RemoveDuplicates Columns:=Array(2, 3, 4, 5, 7), _ Header:=2 Set my_rg = Range("f21").CurrentRegion r = my_rg.Rows.Count Cells(r + 21, "f") = ":الاجمالي" Cells(r + 21, "n").Formula = "=sum(n22:" & "n" & r + 20 & ")" Cells(r + 21, "o").Formula = "=sum(o22:" & "o" & r + 20 & ")" Cells(r + 21, "p").Formula = "=sum(p22:" & "p" & r + 20 & ")" For i = 1 To r - 1 my_rg.Cells(i + 1, 1) = i Next 1: Application.ScreenUpdating = True End Sub

ربما يكون المطلوب Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column = 10 And Target.Cells.Count = 1 Then Target.Offset(, 5) = Target.Offset(, -8) End If Application.EnableEvents = True End Sub

ممكن الحل هنا Example salim.rar

هذا ملف بواسطة اكواد VBA يكفي ان تكتب في الخلية I3 المطلوب لتظهر النتيجة فوراً بعد الضغط على Enter كود تحديد اخر سعر salim with macro.rar

الحل مرفق كود تحديد اخر سعر salim.rar

هذه المعادلة مع (Ctrl+Shift+Enter)و ليس Enter وحدها )لانها معادلة صفيف =INDEX($F$4:$F$100,MAX(IF($D$4:$D$100=$I$3,ROW($D$4:$D$100)-ROW($D$4)+1,0))) او هذه مع (Ctrl+Shift+Enter) =LOOKUP(MAX($F$4:$F$100)+1,IF(--($D$4:$D$100=$I$3),$F$4:$F$100))

جرب هذا الملف Time_work.rar

جرب هذا الملف Move_down.rar

استبدل الكود بهذا Sub all() ' ' Range("a1").Select ActiveCell.FormulaR1C1 = "1" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do Until ActiveCell.Row > 50 ActiveCell = ActiveCell.Offset(14).Select ActiveWindow.SelectedSheets.PrintOut Loop Range("a1").Select End Sub

بعد اذت اخي بن علية هذا الحل Num Order Salim.rar

جرب هذا الملف الكود Private Sub cmddel_Click() Dim x$, y$ x = Application.InputBox("حدد العامود الاول", "Excel tel you", Type:=2) y = Application.InputBox("حدد العامود الثاني", "Excel tel you", Type:=2) On Error GoTo 1 ActiveSheet.Columns.Hidden = False '=================================== Range(Cells(1, x), Cells(1, y)).EntireColumn.Delete 'للحذف 'Range(Cells(1, x), Cells(1, y)).EntireColumn.Hidden = True ' للاخفاء '=================================== Exit Sub 1: ActiveSheet.Columns.Hidden = False End Sub استعمل احد السطرين (او الحذف او الاخفاء في الكود) وذلك بوضع فاصلة عليا بجانب السطر الذي لا تريده و ازالتها من السطر الاخر الملف مرفق hide_columns.rar

وماذا نستفيد من جداول فارغة؟؟؟؟؟.................

جرب هذا الملف الاوائل على مستوى الفصل والنوع Salim.rar