سليم حاصبيا

الصفحة Officena من هذا الملف Random_list 4.xlsm

يرجى حذف هذه الجملة من الكود (وقعت سهواُ) Range("c" & i).Select لانها تشكل عيئاً على الكود بالاضافة الى انها تجعل رأس الجداول غير مرئية بعد تنفيذه

لك ما تريد Random_list 3.xlsm

تم معالجة الامر الكود Option Explicit Sub Rand_Names() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim i%, k%, Final_Row% Dim x As Long x = Cells(2, Columns.Count).End(1).Column + 1 If x < 4 Then x = 4 Final_Row = Cells(Rows.Count, 3).End(3).Row With CreateObject("System.Collections.SortedList") For i = 2 To Final_Row .Item(Rnd) = Range("c" & i) Next i For i = 0 To .Count - 1 Cells(k + 2, x) = .GetByIndex(i) k = k + 1 Next i End With End Sub الملف Random_list 2.xlsm

جرب هذا الملف الماكرو Option Explicit Sub Rand_Names() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim i%, k%, Final_Row% Final_Row = Cells(Rows.Count, 1).End(3).Row With CreateObject("System.Collections.SortedList") For i = 2 To Final_Row .Item(Rnd) = Range("a" & i) Next i For i = 0 To .Count - 1 Cells(k + 2, 3) = .GetByIndex(i) k = k + 1 Next i End With End Sub الملف مرفق Random_list.xlsm

بعد اذن اخي محمد هذه معادلة واحدة تدرج اينما تريد و تسحب نزولاُ (31 صف او اكثر) =IF(ROWS($A$1:A1)>DAY(EOMONTH(DATE($E$2,$E$1,1),0)),"",DATE($E$2,$E$1,ROWS($A$1:A1)))

بالاضافة الى ما ورد بالمشاركة السابقة يمكن استبدال الماكرو بهذا (اسرع لانه يحتوي على حلقة تكرارية واحدة) Option Explicit Sub Take_Without_Dot() Dim x%, y%, m%, s$, LrB%, LrA% LrA = Cells(Rows.Count, 1).End(3).Row LrB = Cells(Rows.Count, 2).End(3).Row Range("B1:B" & LrB).ClearContents For m = 1 To LrA s = Range("a" & m) x = InStr(s, ".") If x = 1 Then s = Mid(s, 2, Len(s)) y = InStr(Len(s), s, ".") If y Then s = Mid(s, 1, Len(s) - 1) Range("B" & m) = s Next End Sub او استعمال دالة معرفة موجودة في الملف المرفق ماكرو للدالة Option Explicit Function Elim_Chr(Rg As Range, Optional Dot As String) Dim s, x%, y% If IsMissing(Dot) Then Dot = "" s = Rg x = InStr(s, Dot) If x = 1 Then s = Mid(s, 2, Len(s)) y = InStr(Len(s), s, Dot) If y Then s = Mid(s, 1, Len(s) - 1) If s = 0 Then s = "" Elim_Chr = s End Function CChr with function.xlsm

من فضلك ارفع ملفاً مختصرا"(حوالي 50 صف للعمل عليه)و ليس 15000 صف مما يضيع الوقت لمعاينة النتائج و هل تريد ذلك لكل العملاء ام لعميل واحد معين

في اي خلية هذا المعادلة =TEXT(TODAY(),"d/m/yyy")&" "&TEXT(NOW(),"hh:mm:ss")

ريما كان المقصود هذا الشئ Example 2.xlsx

يمكن ايضاً استعمال الماكرو لهذا الغرض الماكرو Option Explicit Sub remove_chr() If ActiveSheet.Name <> "salim" Then Exit Sub Range("d:d").ClearContents Dim Arr, k%, i%, m% k = Cells(Rows.Count, 1).End(3).Row For m = 1 To k Arr = Split(Range("A" & m), Chr(46)) For i = LBound(Arr) To UBound(Arr) If Arr(i) <> "" Then _ Arr(i) = Arr(i) & Chr(46) Next Arr = Join(Arr, "") If Arr <> "" Then _ Range("A" & m).Offset(0, 3) = Mid(Arr, 1, Len(Arr) - 1) Next End Sub الملف مرفق TEST Salim.xlsm

جرب هذا الملف TEST Salim.xlsx

حرب هذا الماكرو Option Explicit Sub Del_row() Dim i As Long Dim lr As Long: lr = Cells(Rows.Count, 1).End(3).Row Range("CV2:CV" & lr).Formula = "=SUMPRODUCT(--(A2&B2&C2=$A$2:A2&$B$2:B2&$C$2:C2))" Range("CV2:CV" & lr).Value = Range("CV2:CV" & lr).Value For i = lr To 2 Step -1 If Cells(i, "CV") > 1 Then Cells(i, "CV").EntireRow.Delete Next Range("CV:CV").ClearContents End Sub الملف مرفق test salim.xlsm

يوضع هذا الماكرو في حدث الصفحة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column = 1 And Target.Row > 2 _ And Target.Count = 1 Then Target.Offset(0, 1).Resize(, 4).ClearContents Target.Offset(, 1).Resize(, UBound(Split(Trim(Target), _ " ")) + 1) = Split(Trim(Target), " ") End If Application.EnableEvents = True End Sub

جرب هذا الملف تقسيم نصوص الى اعمدة salim.xlsm

تم معالجة الموضوع Salim_filter.xlsm

الملف الذي ارسلته مصاب بفيروس و قد رفض الجهاز فتحه لذلك انشأت لك ملفاً جديداُ بنفس البيانات مع المعادلات المطلوبة Hisham_Kamal.xlsx

تم التعديل على الملف بما هو مناسب تم حماية المعادلات لعدم العيث بها عن طريق الخطأ المخزون Salim1.xlsx

جرب هذا الملف المخزون SALIM.xlsx

اكتب هذا السطر في الكود مباشرة بعد كلمة Sub If ActiveSheet.Name<>"XXXX" then Exit Sub اكتب اسم الشيت مكان XXXX

لم افهم في البداية ما هو المطلوب لذلك هذا التعدبل على الكود Sub MoudinDa7en() Dim Final_row% Dim My_rg As Range Dim i% i = 1 Final_row = Cells(Rows.Count, 2).End(3).Row Set My_rg = Range("c2:c" & Final_row) Do Until My_rg.Cells(i) = vbNullString With My_rg.Cells(i) On Error Resume Next If Not IsNumeric(.Value) Then .Value = 0 If .Value - .Offset(, 1) > 0 Then .Offset(, 2) = .Value - .Offset(, 1) .Offset(, 3) = 0 Else .Offset(, 3) = Abs(.Value - .Offset(, 1)) .Offset(, 2) = 0 End If i = i + 1 End With Loop End Sub

جرب هذا الماكرو Option Explicit Sub MoudinDa7en() Dim Final_row% Dim My_rg As Range Dim my_sum# Dim i% i = 1 Final_row = Cells(Rows.Count, 2).End(3).Row Set My_rg = Range("e2:e" & Final_row) Do Until My_rg.Cells(i) = vbNullString On Error Resume Next If Not IsNumeric(My_rg.Cells(i)) Then My_rg.Cells(i) = 0 Select Case My_rg.Cells(i) Case Is < 0 My_rg.Cells(i).Offset(0, -1) = My_rg.Cells(i) Case Is > 0 My_rg.Cells(i).Offset(0, -2) = My_rg.Cells(i) End Select i = i + 1 Loop End Sub

اليك الملف من جديد الحد الأقص Salim new.xlsm

هذا لانه هناك خلايا فارغة بالعامود لتلافي ذلك استبدله بهذا الكود Option Explicit Sub del_row() Dim i%, k% Dim x% k = Cells(Rows.Count, 3).End(3).Row If k < 6 Then k = 6 For i = 6 To k If i > k Then Exit For x = Application.CountIf(Range("c6:c" & i), Cells(i, 3)) If x > 1 Then Cells(i, 1).EntireRow.Delete: i = i - 1: k = k - 1 Next End Sub

جرب هذا الماكرو Option Explicit 'Macro to delete duplicates in Columm Sub del_row() Dim i%, k% Dim x% k = Range("a6").CurrentRegion.Rows.Count For i = 6 To k If i > k Then Exit For x = Application.CountIf(Range("c6:c" & i), Cells(i, 3)) If x > 1 Then Cells(i, 1).EntireRow.Delete: i = i - 1: k = k - 1 Next End Sub