أبومروان

وعليكم السلام ورحمه الله وبركاته

بارك الله فيك فيديو اكثر من رائع منتظرين شروحات اكتر باذن الله

حل اخر للطلب لعله يكون المطلوب ويفي بالغرض اذا ارات البحتث من خلال فتره معينه مثلا من يوم 1 الي يوم 10 من هتكون في الخليه e3 الي هتكون في الخليه f3 كما في الصوره المرفقه Copy of جدول ورديات (1).xlsm

وعليكم السلام ورحمه الله وبركاته الحل بسيط جدا سيب خليه التاريخ e3 فارغه مفاها اي حاجه زاي ما في الصوره المرفقه والكود هيكوم بعمليه البحث من خلال المعطيات المطلوبه وكذالك لامر مع الاسم او الفرع او الورديه

الله ينور ممكن تعمل لينا الاكود بالامثله علي الاكسل

الله ينور علي المجهود ممتاز وفكره الترحيب بالصوت حلوه وممكن الشرح لها وكيفيه عملها منتظرين المشروع بالكامل

وعليكم السلام ورحمه الله وبركاته اتفضل لعله يكون المطلوب جدول ورديات.xlsm

السلام عليكم ورحمه الله وبركاته يرجي ارفاق صوره او الملف بالخطا اذا كان سوالك بظهر رموز واشكال غريبه في الاكسل مثل هذا ("ÇáßÔÝ ÇáÑÆíÓí") يمكنك مرجعه الموضوعات التاليه

وعليكم السلام ورحمه الله وبركاته ما هي كلمه المرور واسم المستخدم

الحمد لله الذي بنعمته تتم الصالحات، وبفضله تتنزل الخيرات والبركات وبتوفيقه تتحقق المقاصد والغايات

وعليكم السلام ورحمه الله وبركاته اليك الحل بالكود لعله يكون المطلوب 👇 Sub SeparateSubjects() Dim ws As Worksheet Dim lastRow As Long Dim i As Long, j As Long Dim outputRow As Long Dim subjects() As String Dim subject As Variant Set ws = ThisWorkbook.Sheets(1) lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row outputRow = 6 ws.Range("D6:E1000").ClearContents For i = 6 To lastRow Dim subjectsText As String subjectsText = ws.Cells(i, "C").Value Dim seatNumber As String seatNumber = ws.Cells(i, "b").Value subjects = Split(subjectsText, " - ") For j = LBound(subjects) To UBound(subjects) ws.Cells(outputRow, "D").Value = seatNumber ws.Cells(outputRow, "E").Value = Trim(subjects(j)) outputRow = outputRow + 1 Next j Next i MsgBox "تم فصل المواد بنجاح!", vbInformation End Sub بالكود.xlsm

السلام عليكم ورحمه الله وبركاته استاذ @ashrafelsisi حاول شرح المطوب وارفاق شيت للعمل عليه ما هو الطلوب بالتحديد

اتفضل الاكواد بعد التعديل لعله يكون المطلوب واخبرنا بالنتجه اليك بعض الاكواد ممكن تساعدك كود مسح الخلايا بعد الترحيل اخر كود الترحيل وغير النطاق زاي ما هو موضع wsSrc.Range("B13:J13").ClearContents لو مش عايز ترحل لو الخلايا فارغه قبل كود الترحيل وغير النطاق زاي ما هو موضح If WorksheetFunction.CountA(wsSrc.Range("B4:J4")) = 0 Then MsgBox "الخلايا فارغة لم يتم الترحيل.", vbExclamation Exit Sub End If Sub Transfer1() Dim wsSrc As Worksheet, wsDst As Worksheet Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil1") If WorksheetFunction.CountA(wsSrc.Range("B4:J4")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If If WorksheetFunction.CountA(wsSrc.Range("B6:I6")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If wsDst.Range("A6:I6").Value = wsSrc.Range("B4:J4").Value wsDst.Range("J6:Q6").Value = wsSrc.Range("B6:I6").Value End Sub Sub Transfe12() Dim wsSrc As Worksheet, wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil12") If WorksheetFunction.CountA(wsSrc.Range("B9:J9")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B9:J9").Value End Sub Sub Transfe13() Dim wsSrc As Worksheet, wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil13") If WorksheetFunction.CountA(wsSrc.Range("B13:J13")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B13:J13").Value wsSrc.Range("B13:J13").ClearContents End Sub Copy of Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb

وعليكم السلام ورحمه الله وبركاته اتفضل الكود بالطلب الاول لعله يكون المطلوب 👇 Sub TransferDataValues() Dim wsSrc As Worksheet, wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil1") nextRow = wsDst.Cells(wsDst.Rows.Count, "A") '.End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow End If wsDst.Cells(nextRow, "A").Resize(4, 9).Value = wsSrc.Range("B3:J6").Value End Sub اتفضل الكود بالطلب التاني لعله يكون المطلوب 👇 Sub Transfe12() Dim wsSrc As Worksheet Dim wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil12") nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B9:J9").Value End Sub اتفضل الكود بالطلب التالت لعله يكون المطلوب 👇 Sub Transfe13() Dim wsSrc As Worksheet Dim wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil13") nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B13:J13").Value wsSrc.Range("B13:J13").ClearContents End Sub Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb

وعليكم السلام ورحمه الله وبركاته يمكنك مشاهده الموضوع ادناه لعله يفيدك 👇