سليم حاصبيا

فقط أريد أن اعرف اي ماكرو استعملت الاول او الثاني لان الاول يتعاطى مع الارقام فقط اما الثاني مع كل شيء (اذا كانت تسمية الملفات نصوصاً)

اليك هذا الماكرو الجديد الذي من المفروض ان يعمل على اي اصدار اكسل Option Explicit Sub rand_File_Array() Rem =============>>Created By Salim Hasbaya 15/6/2019 If ActiveSheet.Name <> "SALIM" Then Exit Sub Dim i%, LRJ%, LRA%, LRB% Dim MY_RG As Range Dim my_arr() LRB = Cells(Rows.Count, "B").End(3).Row LRJ = Cells(Rows.Count, "j").End(3).Row LRA = Cells(Rows.Count, "A").End(3).Row + 2 If LRA + 1 > LRJ Then MsgBox "Number of Employees > then Number of files " Exit Sub End If Set MY_RG = Range("J2:J" & LRJ) Range("B2:b" & LRA + 1).ClearContents Dim K%: K = 1 Dim x For i = 1 To MY_RG.Cells.Count ReDim Preserve my_arr(1 To K) Randomize my_arr(K) = Rnd() K = K + 1 Next K = 2 For i = LBound(my_arr) To UBound(my_arr) x = Application.Match(Application.Small(my_arr, i), my_arr, 0) Range("b" & K) = MY_RG.Cells(x) K = K + 1 Next Erase my_arr End Sub الماف مرفق Random_Files_Array.xlsm

اريد معرفة على اي اصدار اكسل تعمل

جرب هذا الكود Option Explicit Sub rand_File_for_employe() Rem =============>>Created By Salim Hasbaya 15/6/2019 If ActiveSheet.Name <> "SALIM" Then Exit Sub Dim i%, LRJ%, LRA Dim myStart#, myEnd# Dim MY_RG As Range LRJ = Cells(Rows.Count, "j").End(3).Row LRA = Cells(Rows.Count, "A").End(3).Row + 2 Set MY_RG = Range("J2:J" & LRJ) myStart = Application.Min(MY_RG) myEnd = Application.Max(MY_RG) Range("B2:b29").ClearContents With CreateObject("System.Collections.SortedList") For i = myStart To myEnd .Item(Rnd) = i Next i i = 0 Do Until i = LRA Range("B" & i + 2) = .GetByIndex(i) i = i + 1 Loop End With End Sub الملف مرفق Random_Files.xlsm

لعمل ذلك هذا الماكرو Option Explicit Sub ALL_data() Dim B As Worksheet: Set B = Sheets("SALIM") Dim sh_name$: sh_name = B.Range("j1") On Error Resume Next If Len(Sheets(sh_name).Name) = 0 Or sh_name = vbNullString Then Exit Sub On Error GoTo 0 Dim N As Worksheet: Set N = Sheets(sh_name) Dim Dic As New Dictionary Dim i%: i = 2 B.Range("a4").CurrentRegion.Clear With N Do Until .Range("a" & i) = vbNullString Dic(i - 2) = .Range("a" & i).Resize(, 64) i = i + 1 Loop For i = 0 To Dic.Count B.Range("a" & i + 5).Resize(, 64) = Dic.Item(i) Next End With With B.Range("a5").CurrentRegion .Interior.ColorIndex = 35 .Borders.LineStyle = 1 .InsertIndent 1 End With N.Range("a1").Resize(, 64).Copy _ B.Range("a4") Dic.RemoveAll End Sub الملف مرفق صفحة SALIM _Salim_File_NEW.xlsm

في الخلية G5 هذه المعادلة =IF(I7>=1750,0,(ROUND((ROUND(I7/4,2))-(QUOTIENT((ROUND(I7/4,2)),1)),2))) وفي الخلية H5 هذه المعادلة =IF(I7>=1750,175,QUOTIENT((ROUND(I7/4,2)),1)) اذا لم تعمل المعادلات استبدل الفاصلة "," بفاصلة منقوطة ";" لتبدو هكذا =IF(I7>=1750;0;(ROUND((ROUND(I7/4;2))-(QUOTIENT((ROUND(I7/4;2));1));2))) =IF(I7>=1750;175;QUOTIENT((ROUND(I7/4;2));1)) الملف مع المعادلات Jineh_Korsh.xlsx

واحد من هذين الماكروين البسيطين Sub From_cel_to_tab() Dim k%: k = 4 Dim sh For Each sh In Sheets sh.Name = Range("M" & k) k = k + 1 Next End Sub Option Explicit Sub From_Tab_To_cel() Dim k%: k = 4 Dim sh For Each sh In Sheets Range("M" & k) = sh.Name k = k + 1 Next End Sub

(Isnumber(B2 تعطينا True و كذلك (Isnumber(B3 تعطينا True بالنتيجة True=True فكيف لا تكونان ارقاماً لتفريب وجهة النظر جرب اكتب هذه المعادلة في اي خلية =.5 و قم بنتسيق الخلية بهذا الشكل ?/?

‍نفس الملف لكن بواسطة vba Option Explicit Sub Get_Exrta_values() Dim Dic As Object Set Dic = CreateObject("Scripting.Dictionary") Dim S As Worksheet: Set S = Sheets("Sheet1") Dim T As Worksheet: Set T = Sheets("SALIM") Dim lrS%: lrS = S.Cells(Rows.Count, "b").End(3).Row Dim My_Rg As Range: Set My_Rg = S.Range("B2:b" & lrS) Dim My_max%: My_max = T.Range("h2") Dim k, m%: m = 2 T.Range("A" & m).CurrentRegion.Offset(1).ClearContents Dim i% Dim my_st, mY_val With Dic For i = 1 To My_Rg.Cells.Count mY_val = _ Application.CountIf(My_Rg, My_Rg.Cells(i)) If mY_val >= My_max Then my_st = My_Rg.Cells(i) If Not .Exists(my_st) Then Dic.Add my_st, 1 Else Dic(my_st) = _ Dic(my_st) + 1 End If End If Next With T.Cells(m, 1).Resize(.Count) .Value = _ Application.Transpose(Dic.keys) .Offset(, 1).Value = _ Application.Transpose(Dic.Items) .Offset(, 2).Resize(Dic.Count).Formula = _ "=SUMPRODUCT((Sheet1!$B$2:$B$100=$A2)*Sheet1!$D$2:$D$100)" End With With T.Range("A" & m).CurrentRegion .Value = .Value End With .RemoveAll End With End Sub الملف مرفق Mabi3at_With_vba.xlsm

الترحيل كلمة سهلة لكن الى اين ايضاً (شبه معروف ) لانه غير معروف العنوان (اقصد الى اي خلية في اي عامود) يرجى ادراج مثالاً يدوياً

الحقيقة الرقم الاول هو : 0.123456789 الرقم الثاني هو : 0.12345679 دون تقريب لكن لماذا ظهر في الاثنين 10/81

ممكن يكون هذا مثال عما تريد Sub macro_with_msgbox() Dim Answer As Byte Answer = MsgBox(" If You Run This Macro I Can't Undo", 4) If Answer = 6 Then Rem ++++++++++++++++++++++++ ' the Macro to Be run for example Range("a2", Range("a1").End(4)).Offset(1) = "Ok" Rem ++++++++++++++++++++++++ End If End Sub الملف مرفق Macro_with_Msgbox.xlsm

اكتب في اي خليتين المعادلة التالية =10/81 و قم بالمقارنة لتجد الجواب صحيح بوجود المسافة يتحول الرقم الى نص وبالتالي لا يمكن القيام بعمليات حسابية

جرب هذا الملف صفحة Salim لا أعلم لما حجم الملف كبير بهذا الشكل Maba3at.xlsx

الدالة VLOOKUP تعمل بامتياز شرط استبدال الرقم 2 بـــ 7 7,0) =VLOOKUP(C7,بيانات!$A$8:$G$14,

للتسلية فقط في الملف رقمان متساويان لكن عندما نسأل البرنامج هل هما متساويان بواسطة "=" يعطينا الجواب False لمن يرغب تفسير ذلك الخلايا محمية ريثما احد من الأعضاء يجد الحل الباسوورد والاجابة فيما بعد من الغاز اكسل .xlsx

‍جرب هذا الماكرو Option Explicit Sub get_data() Dim B As Worksheet: Set B = Sheets("BASMMA") Dim sh_name$: sh_name = B.Range("j1") On Error Resume Next If Len(Sheets(sh_name).Name) = 0 Or sh_name = vbNullString Then Exit Sub On Error GoTo 0 Dim N As Worksheet: Set N = Sheets(sh_name) Dim Dic As New Dictionary Dim i%: i = 2 Dim x With N Do Until .Range("B" & i) = vbNullString If Not Dic.Exists(.Range("B" & i).Value) Then Dic.Add .Range("B" & i).Value, .Range("F" & i).Resize(, 59).Value End If i = i + 1 Loop B.OLEObjects("Combobox1").Object.List = Dic.Keys End With x = N.Range("B:b").Find(B.Range("h2")).Row With B .Range("a2") = N.Cells(x, 1) .Range("b2") = N.Cells(x, 2) .Range("c2") = N.Cells(x, 4) .Range("e2").Resize(59, 1).Value = _ Application.Transpose(Dic.Items(x - 2)) End With Dic.RemoveAll End Sub الملف مرفق ‌Salim_File.xlsm

ربما كان المطلوب Option Explicit Sub all_In_One_Row() Application.ScreenUpdating = False Dim M As Worksheet: Set M = Sheets("MY_SHEET") Dim S As Worksheet: Set S = Sheets("Source") Dim s_row%: s_row = S.Cells(Rows.Count, "P").End(3).Row Dim I%, RGS As Range Dim stp%: stp = 17 Dim x, k%: k = 3 Dim col%, n%: n = 3 Dim y%: y = 3 Dim RO%: RO = 17 Dim Colr%, New_R% M.Range("b17").CurrentRegion.Clear For I = 17 To s_row Step 5 Set RGS = S.Range("b" & I & ":P" & I + 4) x = RGS.Cells.Count M.Cells(stp, 2) = S.Range("Q" & I) stp = stp + 1 For col = k To x + 15 M.Cells(RO, y) = RGS.Cells(n) n = n + 1 y = y + 1 Next y = 3: RO = RO + 1: n = 3 Next M.Columns("B:CL").EntireColumn.AutoFit New_R = M.Range("b17").CurrentRegion.Rows.Count For I = 15 To 90 Step 15 M.Cells(17, I).Resize(26 - New_R).Interior.ColorIndex = 4 Next M.Range("b17").CurrentRegion.Value = _ M.Range("b17").CurrentRegion.Value Application.ScreenUpdating = True End Sub الملف مرفق صفحة MY_SHEET Data_with_dictinary_New.xlsm

في الخلية B5 هذه المعادلة واسحب نزولاً =INDEX('ارقام مالية وشركات '!$D$3:$D$100,MATCH($E5,'ارقام مالية وشركات '!$E$3:$E$100)) في الخلية D29 هذه المعادلة واسحب نزولاً =SUMPRODUCT(--($B$5:$B$24=$E29),$C$5:$C$24) الملف مرفق 12_salim.xlsx

الكود يعمل بشكل ممتاز لا أعرف ما المشكلة عندك الملف مرفق مع الكود Exemple.xlsm

بعد اذن الاستاذ عادل هذا الكود ربما كان أسرع (يدون الكثير من الحلقات التكرارية) تم تغيير اسناء الصفحات (تفادياً لظهور احرف غير مفهومة اثناء نسخه) فقط شيت المصدر ( Source) وشيت الهدف ( Target ) Option Explicit Sub Get_Data() Rem ======>>> Created By Salim Hasbaya On 10/6/2019 Application.ScreenUpdating = False Dim DIC As New Dictionary Dim T As Worksheet: Set T = Sheets("Target") Dim s As Worksheet: Set s = Sheets("Source") Dim laste_ro%: laste_ro = Cells(Rows.Count, "b").End(3).Row Dim i%, stp%: stp = 5 Dim K%, my_key T.Range("a2:p5000").ClearContents With s For K = 17 To laste_ro Step stp DIC.Add .Range("q" & K).Value, _ .Range("B" & K).Resize(stp, 15).Value Next End With i = 2 For Each my_key In DIC.Keys T.Range("a" & i) = my_key T.Range("b" & i).Resize(stp, 15) = DIC(my_key) i = i + stp + 1 Next my_key DIC.RemoveAll Application.ScreenUpdating = True End Sub الملف مرفق Data_with_dictinary.xlsm

جرب هذا الماكرو Option Explicit Sub add_values() Dim r%: r = Range("b7").CurrentRegion.Rows.Count Dim MY_RG As Range Set MY_RG = Range("b8").Resize(r - 1, 5) With MY_RG .Cells(1, 3).Resize(r - 1).Formula = "=SUM(E8,C8)" .Cells(1, 5).Resize(r - 1).Formula = "=SUM(D8,C8)-B8" .Value = .Value End With End Sub

تم معالجة الأمر Drop List_Formula.xlsm

تم معالجة الامر Drop List_New.xlsm