سليم حاصبيا

طريقة اخرى اكثر تفصيلاً الصفحة ALL_In One من هذا الملف Salwa_1.xlsm

العامود الأخضر من هذا الملف Abd_Date.xlsx

في الخلية C2 هذه المعادلة واسحب نزولاً =LEFT(A2,4)*1 اذا لم تعمل معك المعادلة استبدل الفاصلة "," بـــفاصلة منقوطة ";" لتصبح هكذا =LEFT(A2;4)*1

جرب هذا الملف (صفحة Repport) فقط اضغط على الزر RUN Salwa.xlsm

الحل بواسطة المعادلات ليس سهلاُ لوجود الخلايا المدمجة ارفقي ملفاُ بسيطاً 5 أو 6 أسماء مع النتائج المتوقعة (لبس جدول اكثر من نصفه فارغ)

للمرة الالف عدم نسمية الورقة باللغة العربية جرب هذا الماكرو صفحة 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

ربما ينفع هذا الماكرو 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

تم معالجة الأمر 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

جرب هذا الملف Rashidi.xlsx

لا أعلم اذا كان هذا المطلوب Dates.xlsx

لا حاجة للكود Hashem.xlsx

هذه الصورة توضح السبب (الاكسل يقوم بجساب قيمة الخلية الحقيقية ولا ينظر الى تنسيقها)

الضفحة Salim من هذا الملف TwoDates.xlsm

تم التعديل على الماكرو 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

تم التعديل بحيث يقوم الماكرو باضافة الشيتات الى الــ 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

و لما لم تقل ذلك مسبقاُ (جاري التعديل)

تغيير اسماء الشيتات الى 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

لحسن كتابة الكود ونسخه ولصقه تم العمل على 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

جرب هذا الكود 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