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

السلام عليكم ورحمة الله استخدم هذا الكود Sub Suming() Dim LR As Long, i As Long, j As Integer, p As Integer Dim ws As Worksheet Set ws = Sheets("Sheet1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 MsgBox LR i = 6 j = i - 5 p = i - 1 Do While i <= LR ws.Range("A" & i).Value = WorksheetFunction.Sum(ws.Range("A" & j & ":B" & p)) i = i + 7 Loop End Sub

السلام عليكم ورحمة الله ضع المعادلة التالية قى الخلية "" =COUNTIFS($B$3:$B$5000;"السادس ";$C$3:$C$5000;$G3;$D$3:$D$5000;"أ") اما المعادلة التالية فضعها فى الخلية "" =COUNTIFS($B$3:$B$5000;"السادس ";$C$3:$C$5000;$G3;$D$3:$D$5000;"ب") ثم اسحب المعادلتين الى اخر خلية تريدها قم بتغيير اسم الصف فى كل جدول هذا و بالله التوفيق عفوا الخلية الاولى " H3 " و الخلية الثانية " I3 " حساب أعداد الطلاب حسب ثلاث قيم.xlsx

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Cells(Target.Row, 4) <> "" Then Range("B2:D21").Sort key1:=Range("D2"), order1:=xlAscending End If If Cells(Target.Row, 10) <> "" Then Range("H2:J21").Sort key1:=Range("J2"), order1:=xlAscending End If If Cells(Target.Row, 16) <> "" Then Range("N2:P21").Sort key1:=Range("P2"), order1:=xlAscending End If End Sub

السلام عليكم ورحمة الله اجعل هذا الكود هكذا Sub KH_Paste(MySheet As Worksheet, KRow As Integer) On Error Resume Next With MySheet .Range("A" & KRow).PasteSpecial xlPasteValues .Range("A" & KRow).PasteSpecial xlPasteFormats If .Name = "ناجحين" Then .Range("A" & KRow) = KRow - 9 Else .Range("A" & KRow) = KRow / 2 - 4 End If End With Application.CutCopyMode = False End Sub كشف درجات الصف الثاني الابتدائي_5.xls

السلام عليكم ورحمة الله ضع هذا فى نهاية الكود السابق Me.Text1 = "" Me.Text2 = "" Me.Text3 = "" Me.Text4 = "" Me.Text5 = "" Me.Text6 = "" ثم قم باضافة هذا الكود Private Sub SpinButton1_Change() Set ws = Sheets("mark") For i = 9 To 1000 If Me.ComboBox1.Value = ws.Cells(i, 3).Value Then Me.SpinButton1.Value = i + 1 Me.ComboBox1.Value = ws.Cells(i + 1, 3).Value Exit For End If Next End Sub

السلام عليكم ورحمة الله ربما تقصد هذا الشكل التنقل بين السجلات.xlsm

السلام عليكم ورحمة الله استخدم هذا الكود Sub Right_To_Left() Dim ws As Worksheet For Each ws In Worksheets ws.DisplayRightToLeft = True Next End Sub

السلام عليكم ورحمة الله جرب هذا الكود Sub Add_Data() Dim ws As Worksheet, Arc As Worksheet Dim LR As Long Set ws = Sheets("hassila") Set Arc = Sheets("Archives") LR = Arc.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A7:D" & ws.Range("A" & Rows.Count).End(xlUp).Row).Copy Arc.Activate Arc.Range("A" & LR + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False ' :اذا اردت مسح البيانات من الورقة الاولى قم بازالة العلامة التى على اليسار من العبارة التالية 'ws.Range("A7:D" & ws.Range("A" & Rows.Count).End(xlUp).Row-1).ClearContents End Sub

السلام عليكم ورحمة الله ربما Lab يرمز الى Label و Lab.Caption يقصد بها ان العنوان الذى سوف يظهر على Label يكون هو النص او القيمة المكتوبة فى الصف ii و العمود 3

السلام عليكم ورحمة الله اجعل الكود هكذا Sub المجموع() Dim mr As Worksheet Dim LR, i, x, y, z, w, v As Long Dim WFS As Variant Application.ScreenUpdating = False Application.Calculation = xlManual Application.EnableEvents = False Set WFS = WorksheetFunction Set mr = Sheets("mark") LR = mr.Range("c" & Rows.Count).End(xlUp).Row For i = 9 To LR For x = 11 To 157 Step 10 mr.Cells(i, x) = WFS.sum(mr.Cells(i, x - 2), mr.Cells(i, x - 1)) Next x For y = 14 To 157 Step 10 mr.Cells(i, y) = WFS.sum(mr.Cells(i, y - 2), mr.Cells(i, y - 1)) Next y For z = 15 To 157 Step 10 mr.Cells(i, z) = WFS.sum(mr.Cells(i, z - 6), mr.Cells(i, z - 3)) Next z For w = 16 To 157 Step 10 mr.Cells(i, w) = WFS.sum(mr.Cells(i, w - 6), mr.Cells(i, w - 3)) Next w For v = 17 To 157 Step 10 mr.Cells(i, v) = WFS.sum(mr.Cells(i, v - 2), mr.Cells(i, v - 1)) Next v mr.Cells(i, 159) = WFS.sum(mr.Cells(i, 11) + mr.Cells(i, 21), mr.Cells(i, 31), mr.Cells(i, 41), _ mr.Cells(i, 51), mr.Cells(i, 61), mr.Cells(i, 71), mr.Cells(i, 81), mr.Cells(i, 91), _ mr.Cells(i, 101), mr.Cells(i, 111), mr.Cells(i, 121), mr.Cells(i, 131), mr.Cells(i, 141), _ mr.Cells(i, 151)) Next i Application.ScreenUpdating = True Application.Calculation = xlAutomatic Application.EnableEvents = True End Sub

السلام عليكم ورحمة الله شكرا لكلماتك الرقيقة جعل الله لك من دعاءك الطيب نصيبا ووفقنا لما يحب و يرضى

السلام عليكم ورحمة الله جرب هذا الملف للامانة العلمية توجد ورقة مخفية بالملف للتمكن من تحقيق الهدف المبيعات.xlsm

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

السلام عليكم ورحمة الله بورك فيك اخى الكريم محمد جعل الله لك من دعاءك لى نصيبا و زيادة ان شاء الله

السلام عليكم ورحمة الله اجعل الكود هكذا Private Sub CommandButton1_Click() UserForm1.TextBox1 = "" Dim ChekCapn As String, Data As String Dim ChekBx As Control, FData As String For Each ChekBx In Me.Controls If TypeName(ChekBx) = "CheckBox" Then ChekCapn = ChekBx.Caption If ChekBx.Value = True Then Data = Data & "," & ChekCapn FData = Mid(Data, 2, Len(Data) - 1) End If End If Next UserForm1.TextBox1.Value = FData Unload Me End Sub

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

السلام عليكم ورحمة الله انظر الى هذا الملف ربما يكون هذا مطلبك ملف توضيح.xlsm

السلام عليكم ورحمة الله استخدم هذا الكود فى اليوزرفورم الثانى Private Sub CommandButton1_Click() UserForm1.TextBox1 = "" Dim ChekCapn As String, Data As String Dim ChekBx As Control For Each ChekBx In Me.Controls If TypeName(ChekBx) = "CheckBox" Then ChekCapn = ChekBx.Caption If ChekBx.Value = True Then Data = Data & "," & ChekCapn End If End If Next UserForm1.TextBox1.Value = Data Unload Me End Sub

السلام عليكم ورحمة الله البقاء لله انا لله و انا اليه راجعون

السلام عليكم ورحمة الله استخدم هذا الكود Sub AnalysesData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long, j As Long, p As Long Dim Arr, Data As String Set ws = Sheets("ورقة1") Set Sh = Sheets("ورقة2") Sh.Range("B5").Resize(100, 6).ClearContents LR = ws.Range("D" & Rows.Count).End(xlUp).Row Data = Sh.Range("B2") Arr = ws.Range("B3:G" & LR).Value ReDim Preserve Arr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 4) = Data Then p = p + 1 For j = 1 To UBound(Arr, 2) Arr(p, j) = Arr(i, j) Next End If Next If p > 0 Then Sh.Range("B5").Resize(p, UBound(Arr, 2)).Value = Arr End Sub

السلام عليكم ورحمة الله جربى هذا الكود Sub ImportData() Dim ws As Worksheet, Sh As Worksheet Dim p As Integer, x As Integer, LR As Long Dim C As Range, A, B Application.ScreenUpdating = False Set Sh = Sheets("DataReport") A = Sh.Range("K2"): B = Sh.Range("L2"): p = 1 LR = Sh.Range("B" & Rows.Count).End(xlUp).Row For Each ws In ThisWorkbook.Worksheets x = ws.Tab.ColorIndex If x = 10 Then For Each C In ws.Range("A6:A" & ws.Range("A" & Rows.Count).End(xlUp).Row) If C >= B And C <= A Then p = p + 1 Sh.Range(Sh.Cells(p, 2), Sh.Cells(p, 9)).Value = ws.Range(ws.Cells(C.Row, 2), ws.Cells(C.Row, 9)).Value End If Next End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله تفضل Sub ShetName() Dim ws As Worksheet, x As Variant Dim C As Range, WsName As String Dim OpenSht As String For Each ws In ThisWorkbook.Worksheets x = ws.Tab.ColorIndex Set C = ws.Range("A1") If IsNumeric(C.Value) And C.Value > 0 And x = 3 Then WsName = ws.Name & Chr(10) & "Cells Is Value = " & C.Value OpenSht = MsgBox(" Are You Want To Open : " & WsName, vbYesNo) If OpenSht = vbYes Then ws.Activate Exit For End If End If Next End Sub

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

السلام عليكم ورحمة الله ضع هذه المعادلة فى الخلية "G4" اولا ثم اسحب نزولا =LARGE($C$3:$C$50;$E4) ثم ضع المعادلة التالية فى الخلية "F4" ثم اسحب نزولا و لا تنسى الضغط على CRTL+SHIFT+ENTER =IFERROR(INDEX($B$3:$C$50;SMALL(IF($C$3:$C$50=$G4;ROW($C$3:$C$50));ROW($A$1))-2;1);"")

السلام عليكم ورحمة الله استبدل هذه العبارة If IsNumeric(C.Value) And Not IsEmpty(C.Value) And x = 3 Then بهذه العبارة If IsNumeric(C.Value) And C.Value > 0 And x = 3 Then