اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

سليم حاصبيا

أوفيسنا
  • Posts

    8,723
  • تاريخ الانضمام

  • Days Won

    262

كل منشورات العضو سليم حاصبيا

  1. في الخلية C2 هذه المعادلة واسحب نزولاً =LEFT(A2,4)*1 اذا لم تعمل معك المعادلة استبدل الفاصلة "," بـــفاصلة منقوطة ";" لتصبح هكذا =LEFT(A2;4)*1
  2. جرب هذا الملف (صفحة Repport) فقط اضغط على الزر RUN Salwa.xlsm
  3. الحل بواسطة المعادلات ليس سهلاُ لوجود الخلايا المدمجة ارفقي ملفاُ بسيطاً 5 أو 6 أسماء مع النتائج المتوقعة (لبس جدول اكثر من نصفه فارغ)
  4. للمرة الالف عدم نسمية الورقة باللغة العربية جرب هذا الماكرو صفحة Salim من هذا الملف Option Explicit Sub del_data() Dim Ar(), Element Dim Rg_To_copy As Variant Dim My_sh As Worksheet Dim Dic As Object, KY, i% Set My_sh = Sheets("Salim") Ar = Array("B8", "B47") Set Dic = CreateObject("Scripting.Dictionary") For Each Element In Ar For Each Rg In My_sh.Range(Element).Resize(30) _ .SpecialCells(2, 23) Rg_To_copy = Application.Transpose(Rg.Resize(, 7)) Rg_To_copy = Application.Transpose(Rg_To_copy) Dic(Dic.Count) = Join(Rg_To_copy, "*") Next My_sh.Range(Element).Resize(30, 7).ClearContents If Dic.Count Then For i = 0 To Dic.Count - 1 My_sh.Range(Element).Cells(1, 1). _ Resize(, 7).Offset(i) = Split(Dic.Item(i), "*") Next End If Dic.RemoveAll Next Element End Sub الملف مرفق Osama_Dict.xlsm
  5. ربما ينفع هذا الماكرو Option Explicit Sub My_macro() Dim D As Worksheet, RO_A%, i%, m% Dim T As Worksheet Dim arr(), it, MX, Cret, ky Dim Dic As Object Set D = Sheets("DATA") Set T = Sheets("TEST") RO_A = D.Cells(Rows.Count, 1).End(3).Row arr = Array("A", "B", "C") For Each it In arr Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To RO_A If D.Cells(i, 1) = it Then Dic(D.Cells(i, 4).Value) = _ Dic(D.Cells(i, 4).Value) + Val(D.Cells(i, 3)) End If Next i MX = Application.Max(Dic.Items) For Each ky In Dic.Keys If Dic.Item(ky) = MX Then Cret = ky Exit For End If Next ky T.Cells(m + 2, "E") = Cret m = m + 1 Dic.RemoveAll Next it Set D = Nothing: Set T = Nothing Erase arr: Set Dic = Nothing End Sub الملف مرفق Hashem_Dict.xlsm
  6. مع اني لا أحب اليوزر فورم ولا أطيق التعامل معه بالاضافة الى اني لا أحب تسمية الاوراق ياللغة العربية(Youmia) الكود من اليوزر االى الشيت Dim Y As Worksheet Dim Arr_From() Dim Arr_To() Dim Ar_range() '++++++++++++++++++++++++++++++++++++++++++++++ Private Sub cmd_toSheet_Click() Dim i%, How_many%, Bool As Boolean Dim k% Set Y = Sheets("Youmia") Ar_range = Array("B8", "B47", "B86") Arr_From = Array("TB", "TC", "TD" _ , "TE", "TG", "TF", "TH") Arr_To = Array("B", "C", "D", _ "E", "G", "F", "H") ' For i = LBound(Arr_From) To UBound(Arr_From) ' Me.Controls(Arr_From(i)) = Chr(Application.RandBetween(65, 90)) ' Next For i = LBound(Arr_From) To UBound(Arr_From) If Me.Controls(Arr_From(i)) = vbNullString Then MsgBox "Empty TextBox " Exit Sub End If Next For i = 0 To 2 How_many = Application.CountA(Y.Range(Ar_range(i)).Resize(30)) Bool = IIf(How_many = 30, True, False) If Not Bool Then Exit For Next With Y.Range(Ar_range(i)).Cells(1).Offset(How_many) For k = LBound(Arr_From) To UBound(Arr_From) .Offset(, k) = Me.Controls(Arr_From(k)) Next End With End Sub Osama_User.xlsm
  7. لا أعلم اذا كان هذا المطلوب Dates.xlsx
  8. هذه الصورة توضح السبب (الاكسل يقوم بجساب قيمة الخلية الحقيقية ولا ينظر الى تنسيقها)
  9. تم التعديل على الماكرو Private Sub CommandButton1_Click() Dim D As Worksheet Dim Y As Worksheet Dim F_rg As Range Dim How_many%, I%, x%, Ro% Dim Arr_sh(), arr_From() Dim Bool As Boolean Arr_sh() = Array("B8", "B47", "B86") arr_From = Array("E10", "E12", "E14", "H10", "H12", _ "H14", "F16") Set D = Sheets("Data") Set Y = Sheets("Youmia") ' For I = LBound(arr_From) To UBound(arr_From) ' D.Range(arr_From(I)) = Chr(Application.RandBetween(65, 90)) ' Next For I = LBound(arr_From) To UBound(arr_From) If D.Range(arr_From(I)) = vbNullString Then MsgBox "بيانات الحالة غير مكتملة" & Chr(10) & _ "أكمل البيانات", 524352 Exit Sub End If Next For I = 0 To 2 How_many = Application.CountA(Y.Range(Arr_sh(I)).Resize(30)) Bool = IIf(How_many = 30, True, False) If Not Bool Then Exit For Next With Y.Range(Arr_sh(I)).Cells(1).Offset(How_many) For I = LBound(arr_From) To UBound(arr_From) .Offset(, I) = D.Range(arr_From(I)) Next End With For I = LBound(arr_From) To UBound(arr_From) D.Range(arr_From(I)) = vbNullString Next MsgBox "تمت إضافة البيانات", vbInformation, "Done" End Sub
  10. تم التعديل بحيث يقوم الماكرو باضافة الشيتات الى الــ Array اوتوماتيكياً Sub Get_From_Other_WB() Dim mPath$, OtherWB As Workbook Dim F_Name, TS$, m% Dim arr(), itm, x 'arr = Array("Page1", "Page2", "Page3", "Page4") Application.ScreenUpdating = False m = 4 mPath = ThisWorkbook.Path & "\" mPath = mPath & "Main.xlsx" Set OtherWB = Workbooks.Open(mPath) For i = 1 To OtherWB.Sheets.Count ReDim Preserve arr(i - 1) arr(i - 1) = OtherWB.Sheets(i).Name Next OtherWB.Close If UCase(ActiveSheet.Name) <> "TOTAL" Then GoTo BAY_BAY_YA_HILWEEN With Sheets("TOTAL") .Cells(4, "D").Resize(UBound(arr) + 1).ClearContents mPath = ThisWorkbook.Path & "\" For Each itm In arr F_Name = mPath & "[Main.xlsx]" F_Name = "='" & F_Name & itm & "'!B2" .Cells(m, "D").Formula = F_Name m = m + 1 F_Name = "" Next .Cells(4, "D").Resize(UBound(arr) + 1).Value = _ .Cells(4, "D").Resize(UBound(arr) + 1).Value End With BAY_BAY_YA_HILWEEN: Application.ScreenUpdating = True End Sub ALl_SUM_1.xlsm Main.xlsx
  11. و لما لم تقل ذلك مسبقاُ (جاري التعديل)
  12. تغيير اسماء الشيتات الى Data و Youmiya Private Sub CommandButton1_Click() Dim D As Worksheet Dim Y As Worksheet Dim F_rg As Range Dim How_many%, I%, x%, Ro% Dim Arr_sh(), arr_From() Arr_sh() = Array("B8", "B47", "B86") arr_From = Array("E10", "E12", "E14", "H10", "H12", _ "H14", "F16") Set D = Sheets("Data") Set Y = Sheets("Youmia") ' For I = LBound(arr_From) To UBound(arr_From) ' D.Range(arr_From(I)) = Chr(Application.RandBetween(65, 90)) ' Next For I = LBound(arr_From) To UBound(arr_From) If D.Range(arr_From(I)) = vbNullString Then MsgBox "بيانات الحالة غير مكتملة" & Chr(10) & _ "أكمل البيانات", 524352 Exit Sub End If Next For I = 0 To 2 If Application.CountA(Y.Range(Arr_sh(I)).Resize(30)) < 30 Then How_many = Application.CountA(Y.Range(Arr_sh(I)).Resize(30)) End If Exit For Next With Y.Cells(How_many + 8, "B") For I = LBound(arr_From) To UBound(arr_From) .Offset(, I) = D.Range(arr_From(I)) Next End With For I = LBound(arr_From) To UBound(arr_From) D.Range(arr_From(I)) = vbNullString Next MsgBox "تمت إضافة البيانات", vbInformation, "Done" End Sub Osama One_sheet.xlsm
  13. لحسن كتابة الكود ونسخه ولصقه تم العمل على 1- تغيير اسماء الملفات الى (ALl_SUM / تجميع ) و (Main /الرئيسي) 2- يجب ان يكون الملفان في نفس الــ Folder 3- تغيير اسماء الضفحات الى Page2 Page1 ..... بدل 1/2/3/4 الكود Sub Get_From_Other_WB() Dim mPath$ Dim F_Name, TS$, m% Dim arr(), itm arr = Array("Page1", "Page2", "Page3", "Page4") m = 4 If UCase(ActiveSheet.Name) <> "TOTAL" Then GoTo BAY_BAY_YA_HILWEEN With Sheets("TOTAL") .Cells(4, "D").Resize(UBound(arr) + 1).ClearContents mPath = ThisWorkbook.Path & "\" For Each itm In arr F_Name = mPath & "[Main.xlsx]" F_Name = "='" & F_Name & itm & "'!B2" .Cells(m, "D").Formula = F_Name m = m + 1 F_Name = "" Next .Cells(4, "D").Resize(UBound(arr) + 1).Value = _ .Cells(4, "D").Resize(UBound(arr) + 1).Value End With BAY_BAY_YA_HILWEEN: End Sub الملفان مرفقان ضمن هذا الـــ Folder ALl_SUM.xlsm Main.xlsx
  14. جرب هذا الكود Sub Filter_me() Dim Ar_sh(), Itm Dim M As Worksheet Dim Ro%, t%, i%, k%, Y% Dim Cret As Range Dim Filter_rg As Range Set M = Sheets("Main") Set Cret = M.Range("A2:L3") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With k = -1 For i = 1 To Sheets.Count If Sheets(i).Name <> M.Name Then k = k + 1 ReDim Preserve Ar_sh(k) Ar_sh(k) = Sheets(i).Name End If Next t = 8: Y = 8 M.Range("A8:N5000").ClearContents For Each Itm In Ar_sh With Sheets(Itm) If .FilterMode Then .ShowAllData Ro = .Cells(Rows.Count, 1).End(3).Row Set Filter_rg = .Cells(3, 1).Resize(Ro - 3, 12) Filter_rg.AdvancedFilter 1, Cret .Range("A4").Resize(Ro - 3, 12).SpecialCells(12).Copy M.Cells(t, 1).PasteSpecial (12) t = M.Cells(Rows.Count, 1).End(3).Row + 1 M.Cells(Y, "N").Resize(t - Y) = .Name Y = t If .FilterMode Then .ShowAllData End With Next Itm With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Hadi.xlsm
  15. جرب هذا الملف Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim R R = Range("A2", Range("B1").End(4)).Rows.Count + 2 If R > 10000 Then R = 2 If Target.Address = Cells(R, 1).Address _ And Target.Cells.Count = 1 _ And Target <> vbNullString Then Target.Offset(, 1) = _ IIf(Target.Offset(, 1) = vbNullString, _ Date, Target.Offset(, 1)) End If Application.EnableEvents = True End Sub الملف مرفق My_Date.xlsm
  16. ربما هذا ما تقصده Templete.xlsx
  17. تم عمل المطلوب Option Explicit Sub Hide_unhide() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Ar_cel, Ar_n, i% Application.ScreenUpdating = False Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") Sh1.Range("D1:Q1").EntireColumn.Hidden = False Ar_cel = Array("B", "E", "H", "J", "N") Ar_n = Array("E", "H", "k", "N", "Q") For i = LBound(Ar_cel) To UBound(Ar_cel) Sh1.Range(Ar_n(i) & 1).EntireColumn.Hidden = _ IIf(Sh2.Cells(7, Ar_cel(i)) = 0, -1, 0) Next i Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() Hide_unhide End Sub Auto_Jack.xlsm
  18. الصف رقم 3 يجب ان يبقى فارغا لعدم اختلاط الجدول مع خلايا ليس له علاقة بها (كورونا تلعب دورها هنا ايضاً) (يمكن اخفاؤه من اجل عدم الكتابة فيه عن طريق الجطا) الكود Option Explicit Sub salim_Filter() Dim Source As Worksheet Dim Targ As Worksheet Dim Filter_rg As Range Dim Cret As Range Dim Ou As Range Set Source = Sheets("data") Set Targ = Sheets("sheet2") Set Filter_rg = Source.Range("A1").CurrentRegion Set Cret = Targ.Range("A1:A2") Set Ou = Targ.Range("A4") Ou.CurrentRegion.ClearContents Filter_rg.AdvancedFilter 2, Cret, Ou End Sub nany Filter.xlsm
  19. تضع الكود في موديل غير موديل الضفحة (Salim_Mod مثلاً او تنشأ موديل جديد كما تريد) (تفوم بالتعديل كما تريد ضروري اعطاءه اسم جدبد غيرMasrouf ) و يتم استدعاء الكود الجديد من موديل الصفحة (بالضبط كما الكود الأول)
×
×
  • اضف...

Important Information