ابراهيم الحداد

السلام عليكم ورحمة الله استخدم هذا الكود Sub ClearData() Dim ws As Worksheet Dim y As Range Dim lr As Long Set ws = Sheets("كشف المرتبات") lr = ws.Range("b" & Rows.Count).End(xlUp).Row + 1 Set y = Union(Range("E2:F" & lr), Range("H2:I" & lr), Range("K2:K" & lr), Range("M2:O" & lr), Range("Q2:Q" & lr)) y.ClearContents End Sub

السلام عليكم ورحمة الله تفضل Sub Tra_Data() Dim ws As Worksheet, sh As Worksheet Dim LR As Long, i As Long, j As Long, p As Long Dim Arr As Variant, Temp As Variant Set ws = Sheets("بيانات الطلاب") Set sh = Sheets("سجل 41 مستجدين") LR = ws.Range("C" & Rows.Count).End(xlUp).Row Arr = ws.Range("C17:T" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 4) = "مستجد" Then p = p + 1 For j = 1 To 13 Temp(p, Choose(j, 1, 2, 3, 4, 5, 9, 10, 11, 12, 13, 15, 16, 17)) = Arr(i, Choose(j, 1, 6, 7, 8, 9, 12, 3, 13, 14, 15, 10, 11, 16)) Cells(p + 7, "B") = p Next End If Next If p > 0 Then sh.Range("C8").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Tra_Data() Dim ws As Worksheet, sh As Worksheet Dim LR As Long, i As Long, j As Long, p As Long Dim Arr As Variant, Temp As Variant Set ws = Sheets("بيانات الطلاب") Set sh = Sheets("سجل 41 مستجدين") LR = ws.Range("C" & Rows.Count).End(xlUp).Row Arr = ws.Range("B17:T" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If True Then p = p + 1 For j = 1 To 13 Temp(p, Choose(j, 1, 2, 3, 4, 5, 6, 10, 11, 12, 13, 14, 16, 17)) = Arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 13, 4, 14, 15, 16, 11, 12)) Next End If Next If p > 0 Then sh.Range("B8").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله اخى الكريم / ناصر رحم الله اخيك الراحل واسكنه فسيح جناته والهمكم الصبر و السلوان

السلام عليكم و رحمة الله اجعل المعادلة داخل الخلية الاصلية هكذا =IFERROR(INDEX(بيانات!$I:$I; MATCH(A$1; بيانات!$A:$A; 0);0);"")

السلام عليكم ورحمة الله اعتقد انك تقصد هذا الكود Sub saif2() Dim LR As Long, LS As Long, R As Long Dim sh As Worksheet LR = Sheets("البرنامج").Cells(Rows.Count, 1).End(xlUp).Row For Each sh In ThisWorkbook.Worksheets LS = sh.Cells(Rows.Count, 11).End(xlUp).Row For R = 2 To LR If sh.Name = Sheets("البرنامج").Range("A" & R) Then Sheets("البرنامج").Range("P" & R) = sh.Range("K" & LS) Sheets("البرنامج").Range("Q" & R) = sh.Range("L" & LS) End If Next Next sh Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub saif2() Dim LR As Long, LS As Long Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets If sh.Name <> "البرنامج" Then LS = sh.Cells(Rows.Count, 11).End(xlUp).Row sh.Range("K" & LS & ": L" & LS).Copy LR = Sheets("البرنامج").Cells(Rows.Count, 16).End(xlUp).Row + 1 Sheets("البرنامج").Range("P" & LR).PasteSpecial xlPasteValues End If Next sh Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله انسخ الكود التالى والصقه فى موديول واربطه بالزر المتاح فى الورقة Sub Counter() Dim x As Integer x = Range("B1") x = x + 1 Range("B1") = x End Sub

السلام عليكم ورحمة الله ربما يكون هذا هو طلبك Searching Numbers By Text Box.rar

السلام عليكم ورحمة الله الطريقة الوحيدة على حد علمى لعدم تكرار الترحيل هو مسح البيانات القديمة من الورقة الاساسية

السلام عليكم ورحمة الله اليك الكود بعد التعديل Sub ترحيل() ' ' ترحيل ماكرو ' Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Set ws = Sheets("تسجيل الدرجات") Set sh = Sheets("دور ثاني") sh.Range("A10:U" & sh.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents Arr = ws.Range("B9:CS" & ws.Range("D" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 2) = "راسب" Then p = p + 2 For j = 1 To 18 Temp(p, Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 15, 16, 17, 18, 19, 20)) _ = Arr(i, Choose(j, 1, 2, 3, 5, 6, 7, 8, 9, 10, 19, 28, 37, 48, 59, 68, 79, 87, 96)) sh.Cells(p + 9, 1) = p / 2 Next End If Next sh.Range("B10").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

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

السلام عليكم ورحمة الله استخدم الكود الآتى Sub Result2() Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Set ws = Sheets("تسجيل الدرجات") Set sh = Sheets("دور ثاني") sh.Range("A10:U" & sh.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents Arr = ws.Range("B9:CS" & ws.Range("D" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 2) = "راسب" Then p = p + 2 For j = 1 To 18 Temp(p, Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 15, 16, 17, 18, 19, 20)) = Arr(i, Choose(j, 1, 2, 3, 5, 6, 7, 8, 9, 10, 19, 28, 37, 48, 59, 68, 79, 82, 85, 87, 96)) Cells(p + 8, 1) = p / 2 Next End If Next sh.Range("B9").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله الكود يصلح للعديد من الشيتات المهم ان تكون اسماؤها متطابقة

السلام عليكم ورحمة الله الكود بعد التعديل Sub saif() Dim sh As Worksheet LR = Cells(Rows.Count, 1).End(xlUp).Row For Each sh In ThisWorkbook.Worksheets For r = 2 To LR If sh.Name = "البرنامج" Then GoTo 2 If Sheets("البرنامج").Cells(r, 1).Value <> Empty Then If Sheets("البرنامج").Cells(r, 1).Value = sh.Name Then Sheets("البرنامج").Range("D" & r & ":M" & r).Copy qq = sh.Cells(100000, 1).End(xlUp).Row + 1 sh.Range("a" & qq).PasteSpecial xlPasteValues End If End If Next 2 Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله انسخ الكودين الآتيين و الصق الاول فى حدث الورقة SS و الثانى فى حدث الورقة DD Private Sub Worksheet_Activate() Range("H10").Value = Sheets("DD").Range("D7").Value End Sub Private Sub Worksheet_Activate() Range("D7").Value = Sheets("SS").Range("H10").Value End Sub

السلام عليكم ورحمة الله قم بقص الكود كما هو من حدث ورقة1 والصقه فى حدث ThisWorkbook

السلام عليكم ورحمة الله جرب هذا الكود Sub GoodsAcc3() Dim Arr As Variant Dim i As Integer, j As Integer, x As Integer, y As Integer, p As Integer Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents For i = 2 To 5 For x = Cells(i, 3) To Cells(i, 4) If x Then j = j + 1 Cells(j + 1, 2) = x End If Next Next End Sub

السلام عليكم ورحمة الله استخدم الكود التالى فهو اخف واسرع Sub TransNum() Dim LR As Long, R As Long, p As Long, x As Integer LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row For R = 2 To LR x = WorksheetFunction.CountIf(Sheet1.Range("$A$2:A" & R), Sheet1.Range("A" & R)) If x = 1 Then p = p + 1 Sheet2.Cells(p + 1, 1) = Sheet1.Cells(R, 1) End If Next End Sub

السلام عليكم ورحمة الله اجعل المعادلة هكذا =IFERROR(INDEX($A$2:$A$38;SMALL(IF($C$12:$C$38=0;ROW($C$11:$C$37)-1;"");ROW()-11)+1;1);"")

السلام عليكم ورحمة الله بارك الله فيك اخى الكريم ياسر مجرد مرورك على اى موضوع اشارك فيه هو شرف كبير

السلام عليكم ورحمة الله اكتب المعادلة التالية فى الخلية C3 ثم اسحب نزولا ثم اضغط CRTL+SHIFT+ENTER =IFERROR(INDEX(المخزون!$A$2:$A$28;SMALL(IF(المخزون!$C$2:$C$28=0;ROW(المخزون!$C$1:$C$27);"");ROW()-2);1);"")

السلام عليكم ورحمة الله الصق هذه المعادلة فى الخلية C2 و تأكد من تطابق الحروف للحصول على نتيجة سليمة =INDEX(Feuil1!$B$1:$C$2;2;MATCH($B$2;Feuil1!$B$1:$C$1;0))

السلام عليكم ورحمة الله تفضل اخى الكريم Private Sub CommandButton1_Click() Dim i As Long, p As Long For i = 30 To 40 If Me.Controls("TextBox" & i).Value = "" Then Exit Sub p = Val(Me.Controls("TextBox" & i).Value) * Val(Me.TextBox1.Value) Me.Controls("TextBox" & i + 11).Value = p Next Exit Sub End Sub

السلام عليكم ورحمة الله اكتب هذا الكود فى حدث الزر "جمع" Private Sub CommandButton1_Click() Dim i As Long, p As Long p = 0 For i = 28 To 59 If Me.Controls("TextBox" & i).Value = "" Then Exit Sub p = p + Val(Me.Controls("TextBox" & i).Value) Me.TextBox60.Value = p Next Exit Sub End Sub