سليم حاصبيا

جرب هذا الملف العامود I Date calcul.xlsx

انصحك بهذا الملف كي تعمل عليه لانه يحدد لك كل الايام بين تاريخين مع عدم ادراج العطل الاسبوعية ( سبت ,احد, جمعة الخ ...) والعطل الرسمية او القسرية) Working_days_2019.xlsm

take look My_Month.xlsx

في الخلية هذه المعادلة C5 وتسحب يساراً (تنسيق الخلية General ) =MONTH(DATE($B$1,$B$2+COLUMNS($A$1:A1)-1,$B$3)) في الخلية C9 هذه المعادلة (تنسيق الخلية General ) =DAY(DATE($B$1,$B$2,$B$3+COLUMNS($A$1:A1)-1)) بالنسبة لدمج الخلابا فالمعادلات لا تقوم بهذا الشيء (فقط الماكرو)

ألف مبروك استاذ حسين مأمون وان شاء الله معاَ الى ما أبعد من الواجب

جرب هذا الماكرو الضغير Sub my_code() Range("A1:A" & Cells(Rows.Count, 1).End(3).Row + 4) _ .SpecialCells(4).Formula = "=A1" End Sub

تعديل على الماكرو ليتناسب مع ما تريد Option Explicit Sub get_uniq_BY_collection() Dim B As Worksheet, K As Worksheet Dim x%, RG_A As Range, RG_E As Range Dim i%, col As New Collection Dim m%: m = 2 Dim st$, Itm Application.ScreenUpdating = False Set B = Sheets("البيانات"): Set K = Sheets("الخلاصة") Set RG_A = K.Range("A2", Range("A1").End(4)) K.Range("F2", Range("F1").End(4)).ClearContents B.Select Set RG_E = B.Range("E2", Range("E1").End(4)) K.Select i = 1 Do Until RG_A.Cells(i) = vbNullString If Application.CountIf(RG_E, RG_A.Cells(i)) > 0 Then x = 1 Do If RG_A.Cells(i) = RG_E.Cells(x) Then On Error Resume Next col.Add RG_E.Cells(x).Offset(, 1).Value, _ RG_E.Cells(x).Offset(, 1) End If 'col x = x + 1 If x > RG_E.Rows.Count Then Exit Do Loop On Error GoTo 0 If col.Count > 0 Then For Each Itm In col st = st & Itm & "+" Next Itm End If If st <> vbNullString Then _ K.Cells(m, "F") = Mid(st, 1, Len(st) - 1) End If 'error m = m + 1: i = i + 1 Set col = New Collection st = vbNullString Loop Application.ScreenUpdating = True End Sub الملف من جديد Only One_time.xlsm

جرب هذا الماكرو Option Explicit Sub get_uniq() Dim B As Worksheet, K As Worksheet Dim x%, RG_A As Range, RG_E As Range Dim i%, st$ Dim m%: m = 2 Application.ScreenUpdating = False Set B = Sheets("البيانات"): Set K = Sheets("الخلاصة") Set RG_A = K.Range("A2", Range("A1").End(4)) K.Range("F2", Range("F1").End(4)).ClearContents B.Select Set RG_E = B.Range("E2", Range("E1").End(4)) K.Select i = 1 Do Until RG_A.Cells(i) = vbNullString If Application.CountIf(RG_E, RG_A.Cells(i)) > 0 Then x = 1 Do If RG_A.Cells(i) = RG_E.Cells(x) Then st = st & RG_E.Cells(x).Offset(, 1) & "+" End If 'st x = x + 1 If x > RG_E.Rows.Count Then Exit Do Loop If st <> vbNullString Then _ K.Cells(m, "F") = Mid(st, 1, Len(st) - 1) End If 'error m = m + 1: i = i + 1: st = vbNullString Loop Application.ScreenUpdating = True End Sub الملف مرفق tekrar names.xlsm

هذه المعادلة =IF(COUNTIF(البيانات!$E$2:$E$500,الخلاصة!A2)>1,"ERROR",VLOOKUP(الخلاصة!A2,البيانات!$E$1:$F$1500,2,0))

جرب هذا الملف My project_new.xlsm

جرب هذا الكود Option Explicit Sub get_data() Application.ScreenUpdating = False Dim S As Worksheet Dim Cus As Worksheet Dim m%: m = 3 Dim R% Set S = Sheets("Summary") With S .Cells.Clear For Each Cus In Sheets If Cus.Name Like "Customer" & "#" Then R = Cus.Range("B9").CurrentRegion.Rows.Count Cus.Range("B9").CurrentRegion.Copy .Cells(m, 1) With .Cells(m - 1, 1) .Value = Cus.Name .Interior.ColorIndex = 6 End With m = m + R + 2 End If Next Cus .Range("C:C,D:D,H:H").EntireColumn.Delete End With Application.ScreenUpdating = True End Sub الملف مرفق My project.xlsm

لا حاجة لهذا الكم الكبير من Loop يكفي هذا الماكرو Option Explicit Sub consolidate_new() Dim First As Worksheet, Second As Worksheet Dim F_Rg As Range, S_RG As Range Set First = Sheets("ورقة1") Set F_Rg = First.Range("A1").CurrentRegion Set Second = Sheets("ورقة2") Set S_RG = Second.Range("A1").CurrentRegion With Sheets("ورقة3") .Range("A1").CurrentRegion.Offset(1).ClearContents F_Rg.Offset(1).Resize(F_Rg.Rows.Count - 1).Copy .Cells(2, 1) S_RG.Offset(1).Resize(S_RG.Rows.Count - 1).Copy .Cells(F_Rg.Rows.Count + 1, 1) End With End Sub

تم التعديل قليلاً على الملف بحيث انك تستطيعين اختيار بداية البيانات من خلال Combobox و نزولاً 16 صف الصفحة Namouthaz VIVA_Mia_new.xlsm

الاسماء تجدينها في صفحة "Templete_2"

ممكن هذا الكود تم تغيير اسماء الصفحات للغة الاجنبية لسهولة التعامل مع الكود من حيث النسخ واللصق دون ظهور احرف غير مفهومة Option Explicit Sub Extract_by_16() Rem Created by Salim Hasbaya On 12/10/2019 Application.ScreenUpdating = False Dim my_rg, i%, X, last_range As Range Dim S As Worksheet Dim T2 As Worksheet Set S = Sheets("sheet1") Set T2 = Sheets("Templete_2") Dim lra%: lra = S.Cells(Rows.Count, 1).End(3).Row Dim m%: m = 13 For i = m To 2500 Step 37 T2.Cells(i, 4).Resize(16, 2).ClearContents Next m = 13 For i = 2 To lra Step 16 If lra - S.Cells(i, 1).Row < i Then X = lra - i Set last_range = _ S.Cells(i, 1).Resize(X + 1, 2) Exit For End If Set my_rg = S.Cells(i, 1).Resize(16, 2) T2.Cells(m, 4).Resize(16, 2).Value = _ my_rg.Value m = m + 37 Next i If Not last_range Is Nothing Then T2.Cells(m, 4).Resize(X + 1, 2).Value = _ last_range.Value End If Application.ScreenUpdating = True End Sub الملف مرفق VIVA_Mia.xlsm

جرب هذا الملف Split_function.xlsm

بعد نسخ الخلية Ctrl+C 1- حددد المكان المقصود 2- اضغط بالتوالي ATL+E+S+V ثم Enter

الدالة يلزمها Ctrl+Shift+Enter و ليس Enter وحدها

بعد اذن الاخ احمد وزيادة في اثراء الموضوع هذه المعادلة (Ctrl+Shift+Enter) =INDEX(ورقة1!$B$5:$CI$500,MATCH($C$2&$D$2,ورقة1!$B$5:$B$500&ورقة1!$C$5:$C$500,0),MATCH($D6,ورقة1!$B$4:$CI$4,0))

حرب هذا الماكرو Option Explicit Sub ALL_In_One() Dim M As Worksheet Dim sh As Worksheet Dim my_rg As Range Dim t%: t = 2 Set M = Sheets("ورقة4") M.Range("A2", Range("D1").End(4)).ClearContents For Each sh In Sheets If sh.Name <> M.Name Then Set my_rg = sh.Range("A1").CurrentRegion With my_rg M.Cells(t, 1).Resize(.Rows.Count - 1, _ .Columns.Count).Value = _ .Cells(2, 1).Resize(.Rows.Count - 1, _ .Columns.Count).Value t = t + .Rows.Count - 1 End With End If Next End Sub الملف مرفق book1_salim.xlsm

اضغط باستمرار على مفتاح Shift اثناء فتح الملف

المعادلة لا تنظر الى شكل الخلية او لونها او طولها او عرضها او شكل الخط فيها كل ما يعني لها هو محتوى الخلية (رقم / نص / فراغ الخ...) لذلك ريثما تقوم مايكروسوفت باضافة (ما تحلم به من معادلات لتلوين الخلايا) ما علينا سوى استعمال الكود او التنسيق الشرطي لا حظ هذا الملف MY_min.xlsx

لا أعلم بالضبط اذا كان هذا المطلوب Only_one_sheet.xlsm

جرب هذا الماكرو Option Explicit Dim check% Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Columns(1)) Is Nothing _ And Target.Count = 1 Then Call IsHyperlink(Target) If check Then Sheets(Target & "").Visible = True Target.Hyperlinks(1).Follow End If End If Application.EnableEvents = True End Sub Sub IsHyperlink(r As Range) check = r.Hyperlinks.Count End Sub الملف مرفق للتجربة TEST_HYPER.xlsm

استاذ محمود لا لزوم لخمس معادلات في هذه الحالة يكفي معادلة واحدة تكتب في الخلية J3 وتسحب يساراً =IFERROR(VLOOKUP($I$3,$B$6:$G$34,COLUMNS($I$2:J2),0),"")