سليم حاصبيا

جرب هذين الماكروين (النسخ يتم الى Sheet2 اذا لم تكن موجودة قم بانشائها) الأول اصرارك على استعمال الـــ current region الثاني النسخ العادي Option Explicit Sub copy_range_1() Rem copy Using CurrentRegion Dim Rag As Range Set Rag = Sheets("sheet1").Range("A1:W13"). _ SpecialCells(4) Rag.Formula = "=""""" Sheets("sheet1").Range("A1").CurrentRegion.Copy Sheets("sheet2").Range("A1").PasteSpecial Rag.Value = vbNullString With Sheets("sheet2").Range("A1").CurrentRegion .Value = .Value End With Application.CutCopyMode = False End Sub '++++++++++++++++++++++++++++++++++++ Sub copy_range_2() Rem Normal copy Sheets("sheet1").Range("A1:W13").Copy Sheets("sheet2").Range("A1").PasteSpecial Application.CutCopyMode = False End Sub

لا يمكن التعامل مع current region اذا كان يحنوي على خلايا فارغة لذلك ارقع ملفاُ يحتوي على بيانات ولو كانت عشوائية

اصبحت الطلبات اكثر مما توقعت و في كل مرة اقدم لك شيئاً جديداً تنتقده وترفضه وقد قمت بوضع شيت(target) لك بجلب كل الاسماء التي تيدأ يجروف معينه ولكنك تصر على ان تأتي كل الاسماء في خليةواحدة وشرحت لك ان هذا الامر غير ممكن اذ بجب وضع الاسماء الني تيدأ يجروف معينه في قائمة منسدلة او كومبوبوكس و تختار اي من هذه الاسماء للاطلاع على بياناته و حيث اني أرى ان الموضوع أخذ من الوقت والعمل والجهد اكثر مما يستحق وليس هناك احد غيري يقوم بهذه المساعدة لذلك أعتذر عن المتابعة في هذا الموضوع

قم بتغيير الرقم 103 الى اي رقم تريد في المعادلة الأولى (مع الضغط غلى Ctrl+Shift+Enter) وليس Enter وحدها واسحب يساراً الى اخر عامود و نزولاً قدر ما تريد

بقي أنه لا أستطيع التعديل ولا استطيع الاضافة على الشيت. قلت لك التعديل والاضافة تتم قي البشيت الاساسي بالنسبة للتعديل 1-أطلب الاسم الذي تريد التعديل عليه من ComboBox (بعد اختيار الحرف أو الحروف الاولى منه بواسطة الــ TexBox) 2- اذهب الى الشيت الاساسي تراه باللون الاخضر 3- فم بما تريد من تعدبلات 4- هذا كل شيء بالنسبة للاضافة أضف ما تريد من اسماء في الشيت الاساسي (حتى 500 اسم) والماكرو يعمل طبيعي عتد كنابة أول حرف أو حروف

دائماً وأبداً ممنوع دمج الخلايا حيث توجد معادلات (الصفوف 7/ 8 / 9) Yaser_W.xlsm

لا اعرف ما المشكلة عندك انا عندي يعمل بشكل ممتاز جرب ان تغير اسم الملف الى اي اسم تريد (باللغة الأجنبية) ثم ليس هذا الملف الذي رفعته لك الصورة توضح (لا وجود لكلمة Enter)

حرب هذا الملف صفحة Combo_Sheet الصفحة Target ما زالت موجودة لكنها مخفية تم حماية المعادلات لعدم العبث بها عن طريق الخطأ اذا احببت ان تقوم بتعديل شيء ما اذهب الى الصفحة الرئيسية تجد هناك الاسم الذي اخترته من الشيت Combo_Sheet باللون الاخصر (كي لا تقوم بالتفتيش عنه بين كل الاسماء) al7aer2_iist_Combo.xlsm

ما تقول كدا من الصبح al7aer2_iist.xlsm

انا اريد البحث يعمل بمجرد وضع الاسم الاول او الحرف الاول. بحيث تخرج لي جميع الاسماء التي تبدا بالحرف م مثلا هذا من المستحيل العمل هكذا لنفرص ان عندك 5 أسماء تبدأ بالحرف ب مثلاً (بل يا سيدي اسمين) كيف تريد ان تضع هذه الاسماء في خلية واحدة (D5) وهي التي لا تتسع الا الى اسم واحد و بيانات هذا الاسماء (العامود الثاني ) قي حلية واجدة (D7) الخ.....

اسماء الازرار تغيرت عندي في الكود مثلاُ زر الأضافة اصبح اسمه "Cmd_Add" لذلك يجب كتاية الاسماء الصحيحة للازرار في الكود بالنسبة للرسالة Compile Error امسح السطر حيث تشير لك به رسالة الخطأ و اخيراً لما كل هذه المشاكل غليك فقط نسخ البيانات من صفحتك(Sheet2) الى الصغحة التي غندي(Sheet2) و قم بأعمالك على الملف الذي رفعته لك و هذا ملف (مرفق) اخر بنفس الشكل لكن فيه اضافات من حيث التعديل al7aer2_New.xlsm

اذا كان الملف الذي رفعته يعمل انقل بياناتك اليه (فقط محتوبات الصفحة الثانية) كما اذكرك بأنه كان بوجد في ملفك خلايا مدمجة تعيق عمل الكود قمت انا بازالتها أو بجب عليك تسمية النطاق (D9 D7 D5 )الخ..... باسم "Data_Rg" مع ازالة الخلايا المدمجة اولاً كما في الصورة المرفقة

تم اضافة 2 كود باسلوب مبسط الكود الاول للاصافة (تكتب ما تريد اضافته في الخلية D5 مع جميع البيانات ثم ثضغظ الزر "اضافة") تكرار الاسم غير مسموح والثاني للبحث (تكتب ما تريد البحث في الخلية F3 / اللون الأصفر/ ثم تضغط الزر "البحث عن الاسماء") اذا كان الاسم غير موجود تخرج لك رسالة بهذا الأمر Option Explicit Private Sub Cmd_Add_Click() Rem ------------------ Code for ADD --------------- Dim Last_2 As Integer Dim cont%, n%, m%, Ro% Dim ARR Dim First As Worksheet Dim Scd As Worksheet Set First = Sheets("Sheet1"): Set Scd = Sheets("Sheet2") n = Application.CountA(First.Range("Data_Rg")) m = First.Range("Data_Rg").Cells.Count If n <> m Then MsgBox "برجاء إدخال البيانات كاملة", vbCritical, "تنبيه" Exit Sub End If ARR = Split(First.Range("Data_Rg").Address(0, 0), ",") Last_2 = Scd.Range("B:B").Find("").Row cont = Application.CountIf(Scd.Range("B3:B" & Last_2), First.Range("D5").Value) If cont Then MsgBox "هذا الاسم موجود", vbCritical, "تنبيه" Exit Sub End If For Ro = LBound(ARR) To UBound(ARR) Scd.Cells(Last_2, 2).Offset(, Ro) = _ First.Range(ARR(Ro)) Next First.Range("Data_Rg").ClearContents End Sub Rem ------------------ end Of ADD --------------- '++++++++++++++++++++++++++++++ Rem ------------------ code for saerch ___________ Private Sub Cmd_Saerch_Click() Dim Last_2 As Integer Dim cont%, m%, Ro% Dim ARR Dim First As Worksheet Dim Scd As Worksheet On Error Resume Next If Sheet1.Range("F3").Value = "" Then MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "خطأ" Exit Sub End If Set First = Sheets("Sheet1"): Set Scd = Sheets("Sheet2") Last_2 = Scd.Cells(Rows.Count, 2).End(3).Row cont = Application.CountIf(Scd.Range("B3:B" & Last_2), _ First.Range("F3").Value) If cont = 0 Then MsgBox "هذا الاسم غير موجود", vbCritical, "تنبيه" Exit Sub End If ARR = Split(First.Range("Data_Rg").Address(0, 0), ",") m = Scd.Range("B1:B" & Last_2).Find(First.Range("F3").Value, lookat:=1).Row For Ro = LBound(ARR) To UBound(ARR) First.Range(ARR(Ro)) = _ Scd.Cells(m, 2).Offset(, Ro) Next End Sub Rem ------------------ End of saerch ___________ الملف مرفق al7aer2.xlsm

بعد اذن الأستاذ علي اختصار للكود باستعمال الحلقة التكرارية Private Sub CommandButton1_Click() Dim Lrow As Integer Lrow = Sheets("data").Range("b10000").End(xlUp).Row + 1 Dim i% Dim Ar_Data(1 To 9) Dim Ar_Fan(1 To 9) Ar_Data(1) = "B": Ar_Data(2) = "C": Ar_Data(3) = "E" Ar_Data(4) = "F": Ar_Data(5) = "G": Ar_Data(6) = "H" Ar_Data(7) = "I": Ar_Data(8) = "J": Ar_Data(9) = "K" Ar_Fan(1) = "D5": Ar_Fan(2) = "D7": Ar_Fan(3) = "D11" Ar_Fan(4) = "D13": Ar_Fan(5) = "D15": Ar_Fan(6) = "G7" Ar_Fan(7) = "G9": Ar_Fan(8) = "G11": Ar_Fan(9) = "G13" For i = 1 To 9 Sheets("data").Cells(Lrow, Ar_Data(i)) = _ Sheets("fan").Range(Ar_Fan(i)) Sheets("fan").Range(Ar_Fan(i)) = vbNullString Next Sheets("data").Cells(Lrow, "D").Value = _ IIf(OptionButton1.Value = True, "ذكر", "انثى") OptionButton1.Value = "" OptionButton2.Value = "" End Sub

بعض التعديل على الملف 1- بتم العمل على الملف حسب الصور الملف مرفق Kabo_1.xlsm

تعديل =SUMIFS($D$8:$D$12,$B$8:$B$12,B8,$E$8:$E$12,E8)

هذه المعادلة =SUMIFS($D$8:$D$12,$B$8:$B$12,B8)

جرب هذا الملف تم ادراج يوزر جديد لتنفيذ الكود و عليك تنسيقه بالألوان التي تريد Kabo.xlsm

لا أعلم ماذا تقصده بــــ (اكسل اون لاين) لكن هذا نموذج عما تريده (اذا كنت قد فهمت عليك السؤال) يمكن اخفاء جدول كلمات السر والاسماء والدرجات ثم عمل حماية للشيت حتى لا يستطبع احد الاظلاع علبه او بطربقة ثانية وضعة في شيت اخر مخفي (veryHidden) وكل طالب يعرف الباسوورد الخاص به Yazzed.xlsx

أهلاً وسهلاً بكم لمزيد من الاناقة في اخراج الملف تم وضع حدود تفصل الأسماء عن بعضها من اجل قص الأوراق بطريقة منتظمة عند الطباعة اليك الملف من جدبد Ahlawi_Super_16.xlsm

أعيدي تحميل الملف في اخر اجابة لانه قمت بادخال MsgBox ينبه الى وجود اكثر من ادخال لنفس الاسم ولكي حرية الاختيار بالرفض او القبول

ممكن انسى انى ادخلت رقم واضعه مرة اخرى فيتم الجمع لا يمكن ان يحصل هذا الامر الا اذا كان مفصوداً لان الخلابا في العامودين (K,L) تتلون فور ادراج أرقام فيها لذلك قبل ادخال اي رقم تتأكدي ان لون الحلايا المقابلة للاسم في العامودين (K,L) غير ملوّنه واخيراً لنفرض انه بالخطأ تم ادخال رقم 100 الى الاسم رقم 1 عندها تقومين بادخال ناقص 100 (100-) وتحل المشكلة على كل حال تم اضافة شيء ما الى الكود ليقوم بالتنبيه 1-قي حال قمتي باضاقة اي رقم مرة اخرى (لنفس الاسم) تخرج لك رسالة بهذا الامر مع الزر الافتراضي No اذا اردتي الابقاء على كل شيئ كما كان (الاضاقة لمرة واحدة فقط) اضغطي No او Enter واذا ارني الاضافة مرة ثلنية على نفس الاسم Yes الملف من جديد Msgbox_YARA_2User_With_Info..xlsm

لا أعلم اذا كان هذا مفيداً 1-في العامود "K" يتم تسحيل احر مبلغ قبل التعديل 2-في العامود "L" يتم تسحيل احر زيادة Jadid_YARA_2User_With_Info..xlsm

ما هو الترحيل الى العامود J يتم اوتوماتبكياً

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