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

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

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

السلام عليكم و رحمة الله شكرا جزيلا لك

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

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

السلام عليكم و رحمة الله الكود يعمل على نفس الملف و لا يصلح لملف خارجى اذا اردت عملية اللصق فى مكان آخر فقم باستبدال هذه العبارة : If p > 0 Then ws.Range("O2").Resize(p, UBound(Temp, 2)).Value = Temp بهذه العبارة : If p > 0 Then ActiveCell.Resize(p, UBound(Temp, 2)).Value = Temp

السلام عليكم و رحمة الله ..استخدم هذا الكود Sub NoZiro() Dim ws As Worksheet, Lr As Long, p As Long, j As Long Dim Arr As Variant, Temp As Variant, i As Long Set ws = Sheets("ورقة1") Lr = ws.Range("B" & Rows.Count).End(3).Row Arr = ws.Range("B2:G" & Lr).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 5) <> 0 And Arr(i, 5) <> "" Then p = p + 1 For j = 1 To 6 Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("O2").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم و رحمة الله الوجه الآخر لعملة الابداع شكرا جزيلا لك

السلام عليكم ورحمة الله استخدم الكود التالى Sub TrMarks() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ArCol Set Sh = Sheets("Table") Sh.Range("A11:AW" & Sh.Range("B" & Rows.Count).End(3).Row+11).ClearContents Set ws = Sheets("Mark All") LR = ws.Range("B" & Rows.Count).End(3).Row ArCol = Array(1, 2, 3, 4, 5, 6, 7, 13, 18, 19, 24, 29, 30, 35, 40, 41, _ 46, 51, 52, 57, 62, 63, 68, 73, 74, 79, 84, 85, 90, 95, 96, 101, 106, _ 107, 112, 117, 118, 123, 128, 129, 134, 139, 140, 145, 150, 151, 156, 161, 162) Arr = ws.Range("A9:FF" & LR).Value ReDim Tmp(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 = LBound(ArCol) To UBound(ArCol) Tmp(p, j + 1) = Arr(i, ArCol(j)) Tmp(p, 1) = p Next End If Next If p > 0 Then Sh.Range("A11").Resize(p, UBound(Tmp, 2)).Value = Tmp End Sub

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

السلام عليكم و رحمة الله عذرا على التأخير بسبب ظروف خاصة ..ربما يفيدك هذا الكود Private Sub CommandButton2_Click() 'الأوراق المختارة Dim ws As Worksheet, b As Boolean, s As String, x As Integer Dim Arr(), Ln As Long, sh As Worksheet Dim p As Long, Cont As Long, C As Range, j As Integer Dim Tmp(), r As Long, f As Integer '''''''''''''''''''''' ' Arr تخزين اسماء الشيتات المطلوب العمل عليها فى المصفوفة For Each ws In Worksheets For x = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(x) = True Then s = ListBox1.List(x) If s = ws.Name Then ReDim Preserve Arr(p) Arr(p) = s p = p + 1 End If End If Next x Next ws '''''''''''''''''''''' ''Tmp' اعداد للمصفوفة الجديدة On Error Resume Next For i = 0 To UBound(Arr) For Each sh In Sheets(Arr(i)) Ln = Sheets(Arr(i)).Range("A" & Rows.Count).End(3).Row Cont = Cont + Ln Next Next ReDim Preserve Tmp(Cont - 1) r = 0 '''''''''''''''''''''''' ' ' Tmp' تخزين البيانات فى المصفوفة For j = 0 To UBound(Arr) For Each C In Sheets(Arr(j)).Range("A1:A" & Ln) If Len(C) > 0 Then Tmp(r) = C.Value r = r + 1 End If Next Next '''''''''''''''''''''''' ' استدعاء البيانات المخزنة للست بوكس With Me.ListBox1 .Clear .List = Tmp End With End Sub

السلام عليكم و رحمة الله ربما تقصد هذا Sub TrData() Dim ws As Worksheet, sh As Worksheet Dim LR As Long, x As Integer Dim a As Double, Knd As String Dim C As Range Set sh = Sheets("Search") Set ws = Sheets("Data") a = sh.Range("A1"): Knd = sh.Range("B1") LR = ws.Range("A" & Rows.Count).End(3).Row For Each C In sh.Range("A3:A22") On Error Resume Next x = WorksheetFunction.Match(C, ws.Range("C1:X1"), 0) If ws.Cells(1, x + 2) = C.Value Then ws.Cells(LR + 1, 1) = Knd ws.Cells(LR + 1, 2) = a ws.Cells(LR + 1, x + 2) = C.Offset(0, 1) End If Next End Sub

السلام عليكم و رحمة الله ..اجعل الكود هكذا Private Sub CommandButton2_Click() Dim ws As Worksheet, b As Boolean, s As String, x As Integer For Each ws In Worksheets For x = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(x) = True Then s = ListBox1.List(x) If s = ws.Name Then y = y & Chr(10) & ListBox1.List(x) End If End If Next x Next ws MsgBox y End Sub

السلام عليكم و رحمة الله اجعل المعادلة هكذا : =IF(ISERROR(INDEX(datoza;MATCH(B7;INDIRECT($L$5);0);15));"";INDEX(datoza;MATCH(B7;INDIRECT($L$5);0);15))

السلام عليكم و رحمة الله الف مبروك يا كبير ..... نهنئ انفسنا قبل تهنئتك

الف الف مبروك

السلام عليكم و رحمة الله ضع هذا الكود فى حدث الورقة data Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Sheets(Target.Text).Activate End Sub

السلام عليكم و رحمة الله استخدم المعادلة التالية =COUNTIF(OFFSET($A$1;MATCH($F$3;$A$1:$A$9;0)+1;0;9;1);"<="&$F$3)

السلام عليكم و رحمة الله استخدم هذه المعادلة =((D5+E5)+(F5*2))/4

السلام عليكم و رحمة الله استخدم المعادلة التالية =LOOKUP(2;1/(($L$2:$L$21=$L$22)*($M$2:$M$21="حضور"));$K$2:$K$21)

استخدم تلك المعادلة =INDEX($K$2:$K$22;LARGE(IF(L$2:L$22="حضور";ROW(L$2:L$22));1)-1) ثم اضغط على Ctrl + Shift + Enter ثم اسحب حتى آخر خلية فى آخر عمود تريده

السلام عليكم و رحمة الله استخدم المعادلة التالية =SUM(E2;E5;E8)/SUM(COUNTIF(INDIRECT({"E2";"E5";"E8"});">0"))

السلام عليكم و رحمة الله اتبع المسار الآتى : File - Options- Advanced Display option for this workbook ضع علامة صح امام Show sheet tabs

السلام عليكم ورحمة الله اجعل المعادلة هكذا =MATCH(H2;INDIRECT(P2);0)

السلام عليكم ورحمة الله ..استخدم الكود التالى Private Sub CommandButton1_Click() Dim x As Double, y As Double, p x = Me.TextBox1.Value Select Case x Case 1000 To 4999 p = 0.3 Case 5000 To 6999 p = 0.2 Case 7000 To 9999 p = 0.1 Case Is >= 10000 p = 0.05 End Select y = x * p Me.TextBox2.Value = y End Sub