ابو اسامة العينبوسي

السلام عليكم تم بحمد الله نسيت تعديل لون الدائره لاحمر استبدل هذا السطر v.Line.ForeColor.SchemeColor = 8 بــــ v.Line.ForeColor.SchemeColor =10 Test4.rar Test45.rar

السلام عليكم هنا حولنا البيانات الى اكسل ما المطلوب الان ؟ DataforMrkets.rar

السلام عليكم اهلا بك في المنتدى لكن اين البيانات ؟؟

اين هي الاحرف من الشهاده !!؟؟

اين هي الاحرف من الشهاده !!؟؟

اسف لم ارى ردك اخى نزار

السلام عليكم ممكن يكون هكذا ** اخر شهاده الاسم و رقم الجلوس صفر ؟؟؟!! لذلك نتيجتها خطأ Test3.rar

السلام عليكم ________2.rar

السلام عليكم مشكور جدا جدا جزاك الله خيرا

السلام عليكم مشكور جدا جدا جزاك الله خيرا

السلام عليكم checkboxes.rar

السلام عليكم

السلام عليكم Sub test() Sheets("ÇáÇÌãÇáí").Select TR = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1 Cells(TR, 1) = Sheets(1).Cells(5, 7) Cells(TR, 2) = Sheets(1).Cells(5, 3) Cells(TR, 3) = Sheets(1).Cells(5, 5) Cells(TR, 4) = Sheets(1).Cells(12, 5) Sheets(1).Select Sheets(1).Cells(5, 7) = "" Sheets(1).Cells(5, 3) = "" Sheets(1).Cells(5, 5) = "" Sheets(1).Cells(12, 5) = "" End Sub

السلام عليكم

السلام عليكم

السلام عليكم انت تجعل السطر 6 من الصفحة الخلاصه فارغ هنا الكود عدل ليتناسب مع مبتغاك Sub trheelomar() Dim y As Integer Dim xx As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sheets(2).Select Range(Cells(6, 2), Cells(50, 29)).ClearContents Sheets(1).Select xx = Array("", "ËÇãÑ äÇÕÑ", "ÈÇåÑ ÇÍãÏ", "ÚÈÏ ÇáæåÇÈ ÇãÌÏ", "íæÓÝ ÍÓíä", "ßÇãá ãÍãÏ", "ãÍãÏ ÇÍãÏ", "ÑÇÝÊ Óáíã", "ÍÇãÏ íÇÓÑ", "ØÇáÈ ãÕØÝì") For i = 11 To 48 For x = 1 To 10 If Cells(i, 23) = xx(x - 1) Then Select Case Cells(i, 23) Case Is = xx(1) y = 2 Case Is = xx(2) y = 5 Case Is = xx(3) y = 8 Case Is = xx(4) y = 11 Case Is = xx(5) y = 14 Case Is = xx(6) y = 17 Case Is = xx(7) y = 20 Case Is = xx(8) y = 23 Case Is = xx(9) y = 26 End Select yy = Sheets(2).Cells(Rows.Count, y).End(xlUp).Row + 1 If yy = 6 Then yy = Sheets(2).Cells(Rows.Count, y).End(xlUp).Row + 2 End If Sheets(2).Cells(yy, y) = Cells(i, 22) Sheets(2).Cells(yy, y + 1) = Cells(i, 25) Sheets(2).Cells(yy, y + 2) = Cells(i, 24) End If Next Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

السلام عليكم بعد تعديل الكود ليكون اسرع وهو يخص موضوع حساب الخلايا ______________4.rar ______________4.rar

السلام عليكنم مشكور اخ نزار على الحل انا اضفت سطر لكود الاخ خبور وهو : Application.Calculation = xlCalculationManual انسخ الكود و انظر الفرق في السرعة Sub Khcontrol() On Error Resume Next Dim MyRange As Range Dim Studcount As Integer, SheetCount As Integer, StusentsNum As Integer Dim CmNO As Integer, RowsUp As Integer, RowsDown As Integer Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer Dim F As Integer, G As Integer, H As Integer, K As Integer Set KhAppli = Application.WorksheetFunction Set MyRange = Range("ÇáÈíÇäÇÊ") StusentsNum = KhForSheet.TextBox1.Value With MyRange Studcount = KhAppli.CountA(.Range("A1:A" & .Rows.Count)) End With SheetCount = KhAppli.RoundUp(Studcount / StusentsNum, 0) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '=============================== 'ãÓÍ ÇáãÍÊæíÇÊ With æÑÞÉ2 .Cells.Clear End With '=============================== 'äÞá ÇáÈíÇäÇÊ ÈßæÏ ãä ÇßæÇÏ ÈÑäÇãÌ ÎÈæÑÇáãÏÑÓí With æÑÞÉ2 RowsUp = KhForSheet.TextBox2.Value RowsDown = KhForSheet.TextBox3.Value CmNO = KhForSheet.TextBox4.Value A = RowsUp B = 0 For C = 1 To SheetCount For D = 1 To StusentsNum For E = 1 To CmNO F = D + A G = D + B .Cells(F, E) = MyRange.Cells(G, E) Next E Next D A = A + StusentsNum + RowsUp + RowsDown B = B + StusentsNum Next C End With '=============================== 'äÓÎ ÑÄæÓ ÇáÇÚãÏÉ With æÑÞÉ2 Range(Cells(MyRange.Row - RowsUp, 1), Cells(MyRange.Row - 1, CmNO)).Copy H = 1 For K = 1 To SheetCount .Cells(H, 1).PasteSpecial H = H + StusentsNum + RowsUp + RowsDown Next K .Select End With Application.CutCopyMode = False '=============================== Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "Êã ÇÓÊÏÚÇÁ ÇáßÔæÝÇÊ ÚÏÏ " & SheetCount & " ÈäÌÇÍ ", 524288 + 1048576, "ÊÃßíÏ ÇáÇÓÊÏÚÇÁ" Range("A1").Select End On Error GoTo 0 End Sub

السلام عليكم 2003 Example4.rar

السلام عليكم Example3.rar

السلام عليكم كل شئ ممكن بالاكسل لكن لم افهم مرادك

السلام عليكم ____________3.rar

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

السلام عليكم اليك حل سريع (انا الان في العمل) Sub trheelomar() Dim y As Integer Dim xx As Variant Range("rr").ClearContents xx = Array(" ", "ثامر ناصر", "باهر احمد", "عبد الوهاب امجد", "يوسف حسين", "كامل محمد", "محمد احمد", "رافت سليم", "حامد ياسر", "طالب مصطفى") For i = 4 To 42 For x = 1 To 10 If Cells(i, 3) = xx(x - 1) Then Select Case Cells(i, 3) Case Is = xx(0) y = 6 Case Is = xx(1) y = 8 Case Is = xx(2) y = 11 Case Is = xx(3) y = 14 Case Is = xx(4) y = 17 Case Is = xx(5) y = 20 Case Is = xx(6) y = 23 Case Is = xx(7) y = 26 Case Is = xx(8) y = 29 Case Is = xx(9) y = 32 Case Is = xx(10) y = 35 End Select YY = Cells(Rows.Count, y).End(xlUp).Row + 1 Cells(YY, y) = Cells(i, 2) Cells(YY, y + 1) = Cells(i, 5) Cells(YY, y + 2) = Cells(i, 4) End If Next Next End Sub ____________2.rar

السلام عليكم نعم اخى عمر الامر على النحو الذى ذكرت