بحث مخصص من جوجل فى أوفيسنا
Custom Search
|
سليم حاصبيا
أوفيسنا-
Posts
8,723 -
تاريخ الانضمام
-
Days Won
262
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
كل منشورات العضو سليم حاصبيا
-
جرب هذا الملف (صفحة Repport) فقط اضغط على الزر RUN Salwa.xlsm
-
الحل بواسطة المعادلات ليس سهلاُ لوجود الخلايا المدمجة ارفقي ملفاُ بسيطاً 5 أو 6 أسماء مع النتائج المتوقعة (لبس جدول اكثر من نصفه فارغ)
-
نقل الخلايا الممتلئة مكان الفارغة في جدول
سليم حاصبيا replied to osama elmorsy's topic in منتدى الاكسيل Excel
للمرة الالف عدم نسمية الورقة باللغة العربية جرب هذا الماكرو صفحة 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 -
طلب دالة أو ماكرو لجلب بيانات وفق شرط محدد
سليم حاصبيا replied to م.هاشم's topic in منتدى الاكسيل Excel
ربما ينفع هذا الماكرو 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 -
طلب دالة أو ماكرو لجلب بيانات وفق شرط محدد
سليم حاصبيا replied to م.هاشم's topic in منتدى الاكسيل Excel
تم معالجة الأمر Hashem_1.xlsx -
مع اني لا أحب اليوزر فورم ولا أطيق التعامل معه بالاضافة الى اني لا أحب تسمية الاوراق ياللغة العربية(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
-
تحول اي عداد ب 0.25 او 0.75 الى عدد صحيح
سليم حاصبيا replied to الراشدي موسى's topic in منتدى الاكسيل Excel
جرب هذا الملف Rashidi.xlsx -
لا أعلم اذا كان هذا المطلوب Dates.xlsx
-
طلب دالة أو ماكرو لجلب بيانات وفق شرط محدد
سليم حاصبيا replied to م.هاشم's topic in منتدى الاكسيل Excel
لا حاجة للكود Hashem.xlsx -
تفسير سبب عدم تطابق التجميع بمعادلتين اجمالي وفردي
سليم حاصبيا replied to عيسى العامري's topic in منتدى الاكسيل Excel
-
ضبط معادلة جلب البيانات بين تاريخين بدون تكرار
سليم حاصبيا replied to هانى محمد's topic in منتدى الاكسيل Excel
الضفحة Salim من هذا الملف TwoDates.xlsm -
ادخال بيانات لأكثر من جدول بالتتابع في نفس الشيت
سليم حاصبيا replied to osama elmorsy's topic in منتدى الاكسيل Excel
تم التعديل على الماكرو 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 -
كود انشاء معادلة SUM لتجميع قيم من ملف اخر
سليم حاصبيا replied to tlayt kamal's topic in منتدى الاكسيل Excel
تم التعديل بحيث يقوم الماكرو باضافة الشيتات الى الــ 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 -
كود انشاء معادلة SUM لتجميع قيم من ملف اخر
سليم حاصبيا replied to tlayt kamal's topic in منتدى الاكسيل Excel
و لما لم تقل ذلك مسبقاُ (جاري التعديل) -
ادخال بيانات لأكثر من جدول بالتتابع في نفس الشيت
سليم حاصبيا replied to osama elmorsy's topic in منتدى الاكسيل Excel
تغيير اسماء الشيتات الى 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 -
كود انشاء معادلة SUM لتجميع قيم من ملف اخر
سليم حاصبيا replied to tlayt kamal's topic in منتدى الاكسيل Excel
لحسن كتابة الكود ونسخه ولصقه تم العمل على 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 -
بحث بأكثر من شرط في عدة شيتات مع ذكر رقم الشيت
سليم حاصبيا replied to هادي أحمد's topic in منتدى الاكسيل Excel
جرب هذا الكود 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 -
جرب هذا الملف Takrir.xlsx
-
جرب هذا الملف 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
-
ربما هذا ما تقصده Templete.xlsx
-
تم عمل المطلوب 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
-
الصف رقم 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
-
ادخال بيانات لأكثر من جدول بالتتابع في نفس الشيت
سليم حاصبيا replied to osama elmorsy's topic in منتدى الاكسيل Excel
تضع الكود في موديل غير موديل الضفحة (Salim_Mod مثلاً او تنشأ موديل جديد كما تريد) (تفوم بالتعديل كما تريد ضروري اعطاءه اسم جدبد غيرMasrouf ) و يتم استدعاء الكود الجديد من موديل الصفحة (بالضبط كما الكود الأول)