سليم حاصبيا

تمت اضافته الى المشاركة

جرب هذا الكود تم تغيير اسماء الشيتات الى اللغة الاجنبية لسهولة التعامل مع الكود من حيث النسخ واللصق Option Explicit Private Sub Worksheet_Activate() FIL_CDATA_VAL End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub FIL_CDATA_VAL() Dim i As Long: i = 8 Dim DIC As Object Set DIC = CreateObject("Scripting.Dictionary") Do Until Sheets("DATA").Range("C" & i) = vbNullString DIC(Sheets("DATA").Range("C" & i).Value) = "" i = i + 1 Loop With Sheets("RESULT").Range("k5").Validation .Delete .Add 3, Formula1:=Join(DIC.KEYS, ",") End With Set DIC = Nothing End Sub '++++++++++++++++++++++++++++++++++++++++ Sub GET_CERTIFICAT() Dim dat As Worksheet, RES As Worksheet Dim Num%, k%, R, i%, Found_Ro%, Ro%: Ro = 8 Dim FOUND_RG As Range Dim n: n = 3 Dim arr Set dat = Sheets("DATA"): Set RES = Sheets("RESULT") Union(RES.Range("c5"), RES.Range("c19"), RES.Range("c33")) = vbNullString Union(RES.Range("c8:k9"), RES.Range("c22:k23"), RES.Range("c36:k37")) = vbNullString Num = RES.Range("K5") arr = Array(2, 5, 7, 9, 11, 13, 15, 17, 19, 21) For k = 1 To n Set FOUND_RG = dat.Range("a8").CurrentRegion.Columns(3). _ Find(Num, LOOKAT:=1) If FOUND_RG Is Nothing Then Exit Sub R = FOUND_RG.Row RES.Cells(Ro - 3, 3) = dat.Cells(R, arr(0)) For i = 1 To UBound(arr) With RES.Cells(Ro, 3).Offset(, i - 1) .Value = dat.Cells(R, arr(i)) .Offset(1) = dat.Cells(R, arr(i) + 1) End With Next RES.Cells(Ro + 2, 3) = dat.Cells(R, 23) Num = Num + 1: Ro = Ro + 14 Next End Sub الملف مرفق RESULT.xlsm

جرب هذا الملف الكود يعمل في النطاق من A1 الى A10 (اللون الأصفر) الكود Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("A1:A10")) Is Nothing _ And Target.Count = 1 Then Range("B1:B10").ClearContents Target.Offset(, 1) = Range("F1") End If Application.EnableEvents = True End Sub الملف مرفق Writ in Offset.xlsm

لو لاحظت الصفحة الاولى لرأيت انها تحتوي على 20 اسم فقط (قمت بحذف كمية كبيرة من الاسماء لمتابعة عمل الكود والتحقق انه يقوم بالمطلوب ) و لكن اذا نسخت الكود الى ملفك فسوف يعمل على كل الاسماء

كنت قد قلت لك سابقاً ارفع تموذج عما تريد ( 10 - 20 سطراً لا أكثر من 2000 صف) ولا تهدر الوقت بامور لا تجدي نفعاً و الان قد اتضحت الصورة اليك الماكرو المناسب (النتيجة في شيت Salim لانه ربما اردت التعديل بعض الشيء على الماكرو) الماكرو يعمل على كل البيانات مهما زاد عدد الصفوف في العامود الاول Option Explicit Sub Merge_cells() Dim Sh As Worksheet, Sa As Worksheet Dim lr_ShA%, i% Dim my_rg As Range Set Sh = Sheets("sheet1"): Set Sa = Sheets("Salim") Sa.Range("A:A").Clear lr_ShA = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Cells(1, 1).Resize(lr_ShA + 1).Copy Sa.Cells(1, 1).PasteSpecial Application.CutCopyMode = False Sa.Cells(1, 3).Select For i = 1 To lr_ShA Step 2 Sa.Cells(i, 1).Resize(2).Merge Next With Sa.Cells(1, 1).Resize(lr_ShA) .VerticalAlignment = 2 .InsertIndent 1 End With End Sub المثال مرفق tajriba.xlsm

الكود اللازم Sub add_names() Dim Ls% Ls = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1 Sheets("Sans_Merge").Range("K:K").Clear Sheets("Sheet1").Range("A1:A" & Ls).Copy Sheets("Sans_Merge").Range("K1") With Sheets("Sans_Merge").Range("K1:K" & Ls) .UnMerge .SpecialCells(4).Formula = "=k1" End With End Sub الملف من جديد Rxtra_Copy_For_Me.xlsm

جرب هذا الكود Option Explicit Sub give_data() Dim ARR_P, P As Worksheet, D As Worksheet Dim MY_RG As Range, MY_NAME$, R%, i% ARR_P = Array(4, 6, 9, 2, 16, 15, 17, 13, 14, 7, 8, 3, 18, 19) Set P = Sheets("Principal"): Set D = Sheets("DATA") P.Cells(7, "C").Resize(14) = vbNullString MY_NAME = P.Range("A3") Set MY_RG = D.Range("B3").CurrentRegion If MY_RG.Columns("E").Find(MY_NAME, lookat:=1) Is Nothing Then Exit Sub R = MY_RG.Columns("E").Find(MY_NAME, lookat:=1).Row For i = 0 To UBound(ARR_P) P.Cells(7, "C").Offset(i).Value = D.Cells(R, ARR_P(i)) Next Erase ARR_P End Sub الملف مرفق Data_base.xlsm

قم بإنشاء ملف بسيط (نموذج) من 5 لى 10 صفوف تذكر فية المعطيات والتنيجة (يدوياً) و ذلك لاني لم افهم ماذا تريد بالضبط ولا مجال للتخمين واضاعة الوقت

جرب هذا الماكرو Option Explicit Sub divise_cells() Dim i%: i = 1 Dim dic As Object Dim itm, k, m%: m = 1 Range("c1").CurrentRegion.ClearContents Set dic = CreateObject("Scripting.Dictionary") Do Until Range("a" & i) = vbNullString dic(i) = Split(Range("a" & i), ",") i = i + 1 Loop For Each itm In dic.items Cells(m, 3).Resize(, UBound(itm) + 1) = itm m = m + 1 Next dic.RemoveAll: Set dic = Nothing End Sub Taksim.xlsm

انشأ صفحة جديدة باسم Sans_Merge (حيث ستجد الاسماء دون دمج) و نفذ هذا الماكرو (لا يجوز ان تلغي الدمج في الصفحة الاولى حتى لا يتعطل الماكرو الاول) Sub Remove_merg() Dim Ls% Ls = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1 Sheets("Sheet1").Range("A1:A" & Ls).Copy Sheets("Sans_Merge").Range("a1") Sheets("Sans_Merge").Range("A1:A" & Ls).UnMerge Sheets("Sans_Merge").Range("A1:A" & Ls).SpecialCells(4).EntireRow.Delete End Sub الملف مرفق من جديد (النتيجة في الصفحة Sans_Merge) Copy_For_Me_new.xlsm

انا شخصياً تداركت هذا الخطأ و كنت في طريق اصلاحه لكن بما انك سبقتني اليه فجزاك الله خيراً

جرب هذا الماكرو (كان من الافضل عدم وجود خلايا مدمجة) تم تبديل اسم الصفحة الثانية الى اسم بالاجنبية MY_DATA Sub Copy_With_Merged_Cells() Const My_step = 26 Dim M As Worksheet, S As Worksheet Dim I%, Ls%, x%, t% Dim MX%, R% Set M = Sheets("MY_DATA") Set S = Sheets("Sheet1") MX = Application.Max(M.Range("A:A")) Ls = S.Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1 R = M.Range("A:A").Find(MX, LookAt:=1).Row For I = 12 To R Step My_step M.Range("B" & I).Resize(19) = "" Next For I = 1 To Ls Step 20 t = My_step * x + 12 S.Range("A" & I).Resize(20).Copy M.Range("B" & t) x = x + 1 Next M.Columns(2).AutoFit End Sub الملف مرفق Copy_For_Me.xlsm

جرب تغيير الأرقام و ستلاحظ المطلوب Annual_Repport.xls

تفضل يا سيدي بعد اذن الاستاذ حسين طبعاً و بدون الاكواد ومشاكلها (الاكسل يمنع كذلك ادخال اي شي غير الارقام في النطاق من A1 الى A5 )) VERIFICATION.xlsx

جرب الملف التالي Annual_Repport.xls

لماذا تم اخفاء الصفحات وكيف لنا ان نحدد من أين تأتي البييانات

الحل استبدل الماكروات الى هذه Option Explicit Sub Edit_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("b8:l8"), Range("c9:l9")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("D6"), Lookat:=1) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("d6")).Row With Me.Range("b8") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(1, 1) = Cells(r, 13) End With End Sub '+++++++++++++++++++++++++++++++++++++++++++ Sub ADD_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d2"), Lookat:=1) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Find_rg.Row '======================================== With Me.Range("b4") Cells(r, 2) = .Value: Cells(r, 3) = .Offset(, 1): Cells(r, 4) = .Offset(, 2) Cells(r, 5) = .Offset(, 3): Cells(r, 6) = .Offset(, 4): Cells(r, 7) = .Offset(, 5) Cells(r, 8) = .Offset(, 6): Cells(r, 9) = .Offset(, 7): Cells(r, 10) = .Offset(, 8) Cells(r, 11) = .Offset(, 9): Cells(r, 12) = .Offset(, 10): Cells(r, 13) = .Offset(1, 1) End With End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub Ta3dil() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("B4:L4"), Range("C5:L5")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("D2"), Lookat:=1) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("D2")).Row With Me.Range("b4") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(1, 1) = Cells(r, 13) End With End Sub اضافة عبارة LookAt:=1 الى كل العبارات التي تحتوي على Set Find_rg الملف من جديد T-2019_Salim_new.xlsm

لا لزوم للحلقات التكراري في هذه الجالة يكفي هذا الكود البسيط Sub Fill_Empty() Range("B2:F6").SpecialCells(4) = "/" End Sub

تفضل الملف جاهز MAGAZIN.xlsx

يرجى تخفيف من حجم الملف(2.5 Mega) لا يمكن ان تتابع عمل كود من صفحات تحتوي على اكثر من 2000 صف يكفي ان تدرج من 15 الى 20 صف في كل صفحة ومن ثم تعميم الكود على قدر ما تريد من بيانات كما يرجى ادراج الجدول كما يفهمه اكسل كجدول دون تدخل خلايا خارجية في رأس الجدول (ادراج صف فارغ بعد الصف 2 يمكن اخفاءه)

عندها يلزم هذا الكود Dim cel As Range Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("B1:D20")) Is Nothing _ And Target.Count = 1 Then Range("B1:D20").Interior.ColorIndex = 6 For Each cel In Range("B1:D20") If cel < 0 Then cel.Interior.ColorIndex = 50 Next Else Application.EnableEvents = True: Exit Sub End If If Not IsNumeric(Target) Or Target < O Then Target.Interior.ColorIndex = 50 Target.Select MsgBox "خطأ" & Chr(10) & _ "مسموح فقط بأعداد اكبر من صفر", 16, _ vbMsgBoxRight End If Application.EnableEvents = True End Sub الملف من جديد MY_NEW_CODE.xlsm

كان من المطلوب ارفاق ملف لعدم اهدار وقت الاساتذة بانشاء ملف نموذج عما تريد لنفرض ان الوقت الصغير في الخلية A2 والوقت الكبير في الخلية A3 جرب هذا المعادلة (كلما ضغطت على المفتاح F9 او غيرت اي شي في اي خلية تتغير الأوقات العشوائية) =RAND()*($A$3-$A$2)+$A$2 المثال مرفق Rand_time.xlsx

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

جرب هذا الملف الذي لا يسمح لك بكتابة ع اكثر من المطلوب في الخلية C Dawam.xlsx

استعمل الخاصية Option Explicit قبل كلمة Sub بحيث يظهر لك الكود مكان الخطأ باللون الاصفر