محمد هشام.

تفضل اخي =SIERREUR(INDEX(Sheet1!A$2:A$50;PETITE.VALEUR(SI($D$1=Sheet1!$D$2:$D$50;LIGNE(Sheet1!$A$2:$A$50)-1);LIGNE(Sheet1!B1)));"") نقل بيانات.xlsx

تفضل اخي قد تم اضافة شيت جديد يتضمن جميع المواد مع اسماء الاساتدة يتم جلب البيانات من خلاله بحيث عند اختيار مادة معينة يتم اظهار أسماء أساتذة تلك المادة فقط في عمود الأستاذ كما يمكنك إضافة أو تعديل الأسماء بداخل الجدول سيتم إظهارها تلقائيا بالقوائم في عمود الأستاذ مثال لإختيار أساتذة مادة اللغة العربية رابط التحميل https://www.mediafire.com/file/7j6dil06ulnhbr2/RGF_SMAINI+MH.xls/file

أخي بعد الاطلاع على الملف المعادلات ليست الحل بالنسبة لطلبك .خاصة أنك تريد إظهار أسماء اساتذة كل مادة في نفس الخلية . يلزمك إضافة شيت جديد كقاعدة بيانات تتضمن جميع المواد مع أسماء الأساتذة بدون تكرار لأن أغلبية الأساتذة أسماءهم مكررة في أكثر من صف ومن خلالها يتم جلب البيانات بواسطة قوائم منسدلة مترابطة بمعنى عند إختيار مادة معينة من عمود المادة يتم فلترة قائمة عمود الأستاذ على حسب المادة المختارة .

الملف الدي تم الاشتغال عليه ليس به اي فورم فقط واجهة لاستدعاء البيانات من شيتات اخرى قد تم تنفيد الثلاث مطالب التي تم ادراجها داخل الملف

وعليكم السلام ورحمة الله تعالى وبركاته تقصد اخي انك عنداختيار المادة من القائمة يتم اظهار جميع الاساتدة في نفس الخلية وماهي نسخة الاوفيس عندك على الجهاز

العفو اخي الكريم واي اضافة اخرى لا تتردد في طلبها يكفي الظغط على زر افضل اجابة تفاديا لاهدار وقت الاساتدة في الاشتغال على الملف مرة اخرى

وعليكم السلام ورحمة الله تعالى وبركاته اخي كان من الافضل فتح موضوع مستقل انت لديك عدة طلبات وتقوم بطرحها في موضوع قديم قد تمت الاجابة عنه من قبل لدرجة اني لا اعلم ما هو طلبك الان!!!!! على العموم بالنسبة لاخر ملف قمت برفعه مزيدا من التوضيح بخصوص هدا السطر وبعد إضافة بيانات المستلم للمركبة يتم افراغ المحتواى الملون باللون الأصفر ما هي طريقة اضافة البيانات ..

اخي الملف يشتغل عندي بدون مشاكل مع العلم اني اشتغل على نسخة اوفيس 2021 جرب الان او احد الاخوة يقوم بالتجربة ويوافينا بالنتيجة. اليك الملف بعد التعديل __احمد_mh - نسخة 3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته الطلب الاول : تمت اضافة شاشة دخول حيث يتم فتح البرنامج بادخال اسم المستخدم وكلمة المرور وعند ثلاث محاولات خاطئة يتم اغلاق البرنامج اسم المسخدم :admin باسوورد : 1234 Private Sub cmdLogin_Click() Dim user As String Dim password As String user = Me.txtUserID.Value password = Me.txtPassword.Value 'يمكنك نغيير بيانات الدخول من هتا If (user = "admin" And password = "1234") Or (user = "user" And password = "user") Then Unload Me Application.Visible = True Else If LoginInstance < 3 Then MsgBox "كلمة المرور غير صحيحة!!! حاول مرة اخرى", vbOKOnly + vbCritical, "بيانات الدخول غير صالحة" LoginInstance = LoginInstance + 1 Else MsgBox "لقد تجاوزت الحد الأقصى لعدد محاولات تسجيل الدخول. سيتم اغلاق البرنامج", vbOKOnly + vbCritical, "!!!!!!!تنبيه " Unload Me ThisWorkbook.Close Savechanges:=False Application.Visible = True LoginInstance = 0 End If End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = True End Sub الطلب الثاني : حماية الصف الثاني لكي لا يتم حدف العناوين ضع هدا الكود في حدث شيت رئيسي سيتم تثبيث العناوين حتى ولو تعمدت حدفها Private Sub Worksheet_SelectionChange(ByVal Target As Range) Range("B2").Value = "إسم الملف" Range("C2").Value = "المنطقة" Range("D2").Value = "المدينة" Range("E2").Value = "الحي" Range("F2").Value = "رقم المنزل" Range("G2").Value = "رقم رئيسي" Range("H2").Value = "المرتبة" Range("I2").Value = "الرتبة" Range("J2").Value = "الإسم" Range("K2").Value = "مسمى الوظيفة" Range("L2").Value = "التخصص" Range("M2").Value = "رقم الدورة" Range("N2").Value = "رقم الجوال" End Sub الطلب الثالث : حماية اوراق العمل من الحدف او اعادة التسمية قد تم اضافة باسوورد للملف لحماية الاوراق من الحدف يتم تفعيله تلقائيا عند الدخول للبرنامج وعند الرغبة في التعديل . Click Review > Protect Workbook. وادخال كلمة المرور 1234 Private Sub Workbook_Open() LoginInstance = 0 Application.Visible = False frmLogin.Show Feuil1.Select ActiveWorkbook.Protect password:="1234", Structure:=True, Windows:=True End Sub تم تعديل كود انشاء اوراق العمل ليتناسب مع التعديلات الاخيرة للملف '(b)انشاء ورقة جديدة واعادة تسميتها باخر قيمة موجودة في عمود Sub MH2() Dim lastLine As Integer Dim NameSheet As String Dim MH As Boolean lastLine = ThisWorkbook.Sheets("رئيسي").Range("b" & Rows.Count).End(xlUp).Row NameSheet = ThisWorkbook.Sheets("رئيسي").Range("b" & lastLine) MH = feuilleExiste(NameSheet) If MH = True Then MsgBox "يتعدر انشاء ورقة جديدة بسبب وجودها مسبقا ", vbInformation Else 'في حالة تغيير كلمة المرور غلى الملف يجب تغييرها هنا في الكود 'الغاء حماية الملف قبل تنفيد الكود ActiveWorkbook.Unprotect password:="1234" Worksheets("1").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = Worksheets("رئيسي").Cells(Rows.Count, 2).End(xlUp).Value Range("A1").Value = ActiveSheet.Name ThisWorkbook.Sheets("رئيسي").Activate 'اعادة تفعيل حماية الملف ActiveWorkbook.Protect password:="1234", Structure:=True, Windows:=True End If End Sub بالتوفيق .... __احمد_mh - نسخة 2.xlsm

نعم اخي يمكنك دالك بالغاء تفعيل الحماية للخلية A1 في شيت رقم 1 لانها تتضمن اسم ورقة العمل وبها يتم جلب البيانات من شيت رئيسي وبعد حماية الشيت سوف يتم تفعيل الحماية للشيتات الاخرى تلقائيا بعدانشاء الاوراق الجديدة 2 و 3..4......... لان الشيت يتم نسخه كما هو مع تغيير الاسم فقط اما ادا كانت لك رغبة في حماية شيت رئيسي لابد من تعديلات على الاكواد . بما ان الاوراق تتضمن جدول اخر بالاسفل .قم بتحديد الاوراق والخلايا المراد حمايتها وان شاء الله سوف نساعدك للحصول على النتيجة المطلوبة

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي .يتم انشاء شيت جديد تلقائيا عند الكتابة في عمود b مع نسخ المعادلات للحصول على النتائج مباشرة في نفس الشيت المضاف قم بنسخ هذا الكود في حدث شيت ("رئيسي") Private Sub Worksheet_Activate() 'انشاء ارتباط تشعبي باسماء اوراق العمل Dim ws As Worksheet Application.ScreenUpdating = False Worksheets("رئيسي").Range("b3:b500").ClearContents Range("b3").Select For Each ws In ActiveWorkbook.Worksheets If (ws.Name <> "رئيسي") Then ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name ActiveCell.Offset(1, 0).Select Application.ScreenUpdating = True End If Next ws Call MH End Sub '(b)انشاء ورقة جديدة تلقائيا واعادة تسميتها باخر قيمة موجودة في عمود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Or Target.Row <= 2 Then Exit Sub If Target.Column = 2 And Target.Value <> "" And Not (sheetExists(Target.Value)) Then Call Bouton1_Cliquer Sheets("رئيسي").Select End If End Sub Function sheetExists(sheetToFind As String) As Boolean sheetExists = False For Each Sheet In Worksheets If sheetToFind = Sheet.Name Then sheetExists = True Exit Function End If Next Sheet End Function وهدا الكود في module Public Sub MH() '(b)'افراغ خلايا الجدول بشرط وجود فراغ في العمود Dim a& With Sheets("رئيسي") For a = .Cells(.Rows.Count, 3).End(xlUp).Row To 1 Step -1 If .Cells(a, 2) = "" Then Range(Cells(a, 3), Cells(a, 13)).Select Selection.ClearContents .Cells(a + 1, 2).Select End If Next a End With End Sub Sub Bouton1_Cliquer() Dim lastLine As Integer Dim NameSheet As String Dim MH As Boolean lastLine = ThisWorkbook.Sheets("رئيسي").Range("b" & Rows.Count).End(xlUp).Row NameSheet = ThisWorkbook.Sheets("رئيسي").Range("b" & lastLine) MH = feuilleExiste(NameSheet) If MH = True Then MsgBox "يتعدر انشاء ورقة جديدة بسبب وجودها مسبقا ", vbInformation Else Worksheets("1").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = Worksheets("رئيسي").Cells(Rows.Count, 2).End(xlUp).Value Range("a1").Value = ActiveSheet.Name ThisWorkbook.Sheets("رئيسي").Activate End If End Sub احمد_mh.xlsm

طلبك غير واضح أخي الكريم!!! ربما تقصد إنشاء أوراق جديدة باسماء الأساتذة الموجودة في نطاق b31:b46 وتسميته كل ورقة عمل باسم الأستاذ ووضع إسمه باللغة الانجليزية في الخلية A13

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ("E2")/ =SOMMEPROD(($G$9:$G$50=$D$2)*(SOUS.TOTAL(109;DECALER(H9;LIGNE($H$9:$H$50)-LIGNE(H9);0)))) ("E3")/ =SOMMEPROD(($G$9:$G$50=$D$3)*(SOUS.TOTAL(109;DECALER(H9;LIGNE($H$9:$H$50)-LIGNE(H9);0)))) ("E4")/ =SOMMEPROD(($G$9:$G$50=$D$4)*(SOUS.TOTAL(109;DECALER(H9;LIGNE($H$9:$H$50)-LIGNE(H9);0)))) مع الظغط على المفاتيح Ctrl+ Shift+ Enter المبيعات.xlsx

يمكنك استخدام المعادلة التالية =SI(MAX(SI(A2=$A$2:$A$13; $B$2:$B$13))=B2;100; "") مثال (1).xlsx

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub MH_copy() Dim i As Long lastro = Feuil1.Cells(Rows.Count, 3).End(xlUp).Row + 1 Application.ScreenUpdating = False With Cells(1).CurrentRegion For i = 1 To .Rows.Count Step 15 .Rows(i).Resize(15).Copy Range("c" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True Next End With Application.ScreenUpdating = True End Sub E Invoicing2_mh.xlsm

اسف على التاخير صراحة لم اتدكر موضوعك حتى قمت بالمشاركة في احدى المواضيغ المشابهة تفضل اخي اليك حل اخر ربما يفيدك test_MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ....في حالة كانت عندك على الجهاز نسخة اوفيس 2016 او ما قبل يمكنك استخدام المعاداة التالية في الخلية ("G14") مع الظغط على المفاتيح Ctrl+ Shift+ Enter مع سحب المعادلة الى الاسفل =SI(E9="";"";SIERREUR(@Singlecellextract(F9;تعريفات!$B$2:$C$1000;2);"")) ثم التوجه الى المطور واضافة هدا الكود في module Function SingleCellExtract(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) Dim i As Long Dim Result As String For i = 1 To LookupRange.Columns(1).Cells.Count If LookupRange.Cells(i, 1) = Lookupvalue Then Result = Result & " " & LookupRange.Cells(i, ColumnNumber) & "," End If Next i SingleCellExtract = Left(Result, Len(Result) - 1) End Function اما في حالة كنت تمتلك نسخة 2019 وما فوق يمكنك استخدام المعادلة التالية في الخلية ("G14") مع الظغط على المفاتيح Ctrl+ Shift+ Enter =JOINDRE.TEXTE(", ";VRAI;SI(F4=تعريفات!$B$2:$B$1000;تعريفات!$C$2:$C$1000;"")) على العموم قم بتحميل الملفات من المرفقات بما انني استخدم اوفيس فرنسي احاول عدم اعادة صيغة المعادلات تفاديا للاخطاء . بالتوفيق فوسفور _VBA.xlsm نسخ حديثة.xlsx

اخي بعد نسخ المعادلة لا تحاول إنشاء صيغة صفيف بإدخال الأقواس المتعرّجة يدويًا، فلن تحصل على نتيجة معينة، لأن اكسل سيتعامل مع المدخلات كنصوص وليس كصيغة حاول الظغط على المفاتيح Ctrl+ Shift+ Enter

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Find_And_copy() Dim MH As Worksheet, MH2 As Worksheet Dim c As Range, f As Range Dim rngCopy As Range, rngCopyTo Set MH = Worksheet____37 Set MH2 = Worksheet____60 Application.ScreenUpdating = False 'يمكنك تفعيل هدا السطر في حالة الرغبة بحدف البيانات القديمة في نفس العمود المرحل اليه 'Call Find_And_clear '("H9")تحديد رقم العمود المرحل اليه من شيت ادخال الى شيت ارشيف في الخلية For Each c In Application.Intersect(MH.UsedRange, MH.Range("H9")) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then 'رقم صف البحث Set f = MH2.Rows(9).Find(what:=c.Value, LookIn:=xlValues, _ LookAt:=xlWhole) If Not f Is Nothing Then Set rngCopy = MH.Range(c.Offset(1, 0), _ MH.Cells(Rows.Count, c.Column).End(xlUp)) Set rngCopyTo = MH2.Cells(Rows.Count, _ f.Column).End(xlUp).Offset(1, 0) rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value End If End If Next c Worksheet____37.Activate 'مسح البيانات المرحلة 'Range("H10:H39").ClearContents Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub Find_And_clear() '("H9") البحث عن رقم العمود بشرط الخلية 'وافراغ البيانات Dim i As Integer Dim LastRow As Long Dim MyColl As Collection Dim myIterator As Variant Set MyColl = New Collection Application.ScreenUpdating = False MyColl.Add Worksheet____37.Range("H9").Value LastRow = Worksheet____60.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Worksheet____60.Activate For i = 6 To 350 For Each myIterator In MyColl If Cells(9, i) = myIterator Then Range(Cells(10, i), Cells(LastRow, i)).Select Selection.ClearContents Cells(9, i).Select End If Next Next Worksheet____37.Activate Application.ScreenUpdating = True End Sub تقارير (3).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اسماء الاعمدة غير متطابقة ... حاول توضح طلبك اكثر او وضع نمودج للنتيجة المتوقعة لكي نستطيع مساعدتك

بما انك لم تقم بارفاق ملف للتوضيح اكثر ممكن تجرب هدا الحل بالمعادلات للحصول على عدد الاختلافات للصنف الواحد وممكن تضيف عليه تنسيق شرطي لو احببت =SOMME(SI(A3=$B$6:$B$201;1/(NB.SI.ENS($B$6:$B$201;A3;$A$6:$A$201;$A$6:$A$201));0)) TEST.xlsx

للتوضيح فقط الكود الاول يعتمد على عناوين الاعمدة يعني حتى لو لو تم تغيير مكان العمود سوف يتم نسخ البيانات في العمود المناسب لاكن بشرط وجود نفس اسم العمود في شيت 2 وفي حالتك انت لا يوجد تشابه بين عناوين الاعمدة اليك الكود التالي سوف يلبي المطلوب بادن الله Sub Move_MH() Dim lr As Long Application.ScreenUpdating = False With Sheets("Sheet1") lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1 dlg = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row .Range(.Cells(2, "c"), .Cells(lr, "c")).Copy Sheets("Sheet2").Range("A" & dlg + 1) .Range(.Cells(2, "d"), .Cells(lr, "d")).Copy Sheets("Sheet2").Range("C" & dlg + 1) .Range(.Cells(2, "E"), .Cells(lr, "E")).Copy Sheets("Sheet2").Range("E" & dlg + 1) .Range(.Cells(2, "F"), .Cells(lr, "F")).Copy Sheets("Sheet2").Range("I" & dlg + 1) .Range(.Cells(2, "M"), .Cells(lr, "M")).Copy Sheets("Sheet2").Range("G" & dlg + 1) .Range(.Cells(2, "G"), .Cells(lr, "G")).Copy Sheets("Sheet2").Range("K" & dlg + 1) .Range(.Cells(2, "I"), .Cells(lr, "I")).Copy Sheets("Sheet2").Range("M" & dlg + 1) .Range(.Cells(2, "J"), .Cells(lr, "J")).Copy Sheets("Sheet2").Range("O" & dlg + 1) .Range(.Cells(2, "K"), .Cells(lr, "K")).Copy Sheets("Sheet2").Range("Q" & dlg + 1) .Range(.Cells(2, "P"), .Cells(lr, "P")).Copy Sheets("Sheet2").Range("S" & dlg + 1) End With Application.ScreenUpdating = True End Sub Test1.xlsm

أخي قم بالدخول إلى محرر الاكواد وشغل الكود او أعد ربط الزر بالكود copy ملاحظة في حالة كانت لك رغبة بالاحتفاظ بالبيانات السابقة بمعنى انك تريد ترحيل بيانات جديدة كل مرة في اخر صف فارغ دون حدف البيانات القديمة قم بتعطيل هدا الصف من الكود Range("A2:A200,C2:C200,E2:E200,G2:G200,I2:I200,k2:k200,M2:M200,O2:O200,Q2:Q200,S2:S200").ClearContents واليك كود اخر للترحيل بنفس الطريقة مع نسخ البيانات في اخر صف فارغ من العمود الاول Oracle_Sub Sub CopyDataBlocks() Dim SourceSheet As Worksheet Dim TargetSheet As Worksheet Dim ColHeaders As Range Dim MyDataHeaders As Range Dim DataBlock As Range Dim c As Range Dim Rng As Range Dim i As Integer Set SourceSheet = Sheets("Sheet1") Set TargetSheet = Sheets("Sheet2") With TargetSheet Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) End With With SourceSheet Set MyDataHeaders = .Range("A1:U1") Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp)) Set Rng = Rng.Resize(DataBlock.Rows.Count, 1) For Each c In MyDataHeaders If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) <> 0 Then i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0) Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value End If Next c End With End Sub اليك الملف مرة اخرى عليه جميع الاكواد ولك الاختيار Exmple2.xlsm

جميل جدا مزيدا من التألق والابداع بادن الله