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

السلام عليكم ورحمة الله جرب هذا الملف واخبرنى بالنتيجة test.rar

السلام عليكم ورحمة الله الماكرو يعمل على التاريخ الذى يكون اكبر من او يساوالتاريخ المدرج بالخلية ("J3 ") ملحوظة هامة بعض التواريخ فى الملف السنة فيها مكتوبة 1900 اليك الملف New Microsoft Office.rar

السلام عليكم ورحمة الله انسخ هذا الكود و الصقه فى موديول جديد و خصص له زر Sub LastPrices1() For Each cl In Range("A3:A12") x = cl.Offset(0, 1).Value y = cl.Offset(0, 2).Value If cl.Value > Range("J3").Value And x = "بيع" Then ZZ = WorksheetFunction.VLookup(y, Range("I4:K10"), 2, 0) cl.Offset(0, 4).Value = ZZ ElseIf cl.Value > Range("J3").Value And x = "شراء" Then AA = WorksheetFunction.VLookup(y, Range("I4:K10"), 3, 0) cl.Offset(0, 4).Value = AA End If Next End Sub

السلام عليكم ورحمة الله اكتب هذه المعادلة =IF($I5>=$R$5:$R$19;VLOOKUP($I5;$R$5:$T$19;3;1);"")

السلام عليكم ورحمة الله تفضل اخى الكريم مخزن.rar

السلام عليكم ورحمة الله أساتذتى الاجلاء استميحكم عذرا هذا حل بالاكواد لجلب جميع البيانات لشيت الناجحين فقط ينسخ هذا الكود و يلصق فى موديول جديد ويخصص له زر بشيت الناجحين Sub MyArrays2() Range("I11:AP101").ClearContents Dim Arr As Variant, Arr2 As Variant Dim temp As Variant Arr = sheet1.Range("A10:CF" & sheet1.Range("I" & Rows.Count).End(xlUp).Row) Arr2 = Array(5, , 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 25, 26, 27, 28, 31, 32, 33, 34, 52, 58, 64, 70, 73, 74, 75, 76, 84) ReDim temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr2) + 1) For i = 1 To UBound(Arr) If Arr(i, 9) <> "" Then p = p + 1 For j = 0 To UBound(Arr2) On Error Resume Next If p <= Range("H4") Then temp(p, j) = Arr(i, Arr2(j)) End If Next j End If Next i If p > 0 Then Range("I11").Resize(p, UBound(temp, 2)).Value = temp Call Serial End Sub Sub Serial() For R = 11 To Range("K" & Rows.Count).End(xlUp).Row If Cells(R, "I") <> "" Then Cells(R, "J") = R - 10 End If Next End Sub

السلام عليكم ورحمة الله قارن بين هذا الكود و الكود السابق وستلاحظ الفرق بنفسك Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Dim sh As Worksheet, Found Set sh = Sheets("بيانات") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo Skipper Found = Application.Match(Target.Value, sh.Columns(2), 0) Target.Offset(0, 3).Value = sh.Cells(Found, 1).Resize(1, 6).Value Skipper: Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقة فى محرر الاكواد Sub CalcDate() For R = 3 To Range("BY" & Rows.Count).End(xlUp).Row If Cells(R, "BY") <> "" And Cells(R, "BZ") <> "" Then Cells(R, "CA") = Cells(R, "BY").Value + Cells(R, "BZ").Value End If Next End Sub ثم اذهب الى الكود الذى ترغب فى ان يعمل بعده هذا الكود وتكتب هذه التعليمة فى نهاية الكود Call CalcDate

السلام عليكم ورحمة الله اكتب المعادلة هكذا =COUNTIFS(Data!$B$3:$B$488;B12;Data!$D$3:$D$488;">=50" ) ثم اجعل الفصول فى الورقتين بنفس الطريقة

السلام عليكم ورحمة الله بعد اذن الاستاذ سليم جرب اخى هذا الكود Sub SummCol() Lr = Range("B" & Rows.Count).End(xlUp).Row Range("B" & Lr & ":E" & Lr).ClearContents For R = 5 To Lr x = x + Cells(R, "C") y = y + Cells(R, "D") Z = Z + Cells(R, "E") Next LS = Range("B" & Rows.Count).End(xlUp).Row Cells(LS + 2, 2) = "اجمالى الكشف" Cells(LS + 2, 3) = x Cells(LS + 2, 4) = x Cells(LS + 2, 5) = x End Sub

السلام عليكم ورحمة الله ضف العبارة الاولى الى الكود السابق بعد السطر الرابع ثم انسخ الكود الذى يليها وضعه فى حدث الورقة الاولى On Error Resume Next --------------------- Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 8 Then Exit Sub Call Ser_Data End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول جديد وخصص له زر واحفظ الملف باصدار 2003 او اعلى Sub Ser_Data() Dim R As Long, S As Integer, x As Variant Range("I1:K" & Range("H" & Rows.Count).End(xlUp).Row).ClearContents For R = 1 To Range("H" & Rows.Count).End(xlUp).Row For S = 2 To 4 x = WorksheetFunction.VLookup(Cells(R, "H"), _ Range("B1:E" & Range("B" & Rows.Count).End(xlUp).Row), S, 0) Cells(R, S + 7) = x Next Next End Sub

السلام عليكم ورحمة الله اخى العزيز ضع هذين الكودين معا فى موديول واحد واربط الكود الاول بزر التحكم عسى الله ان يكون هذا هو المطلوب ملحوظة صغيرة : الكود قد يستغرق بعض الوقت للتنفيذ Sub Calling_Data() LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row LS = Sheet2.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For R = 2 To LR For S = 2 To LS If Cells(R, "A") = Sheet2.Cells(S, "B") Then If Cells(R, "B") = Sheet2.Cells(S, "A") Then Cells(R, "E") = Sheet2.Cells(S, "C") Cells(R, "F") = Sheet2.Cells(S, "D") End If End If Next Next Application.ScreenUpdating = True Call Calling2_Data End Sub Sub Calling2_Data() LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row LS = Sheet3.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For R = 2 To LR For S = 2 To LS If Cells(R, "A") = Sheet3.Cells(S, "B") Then If Cells(R, "B") = Sheet3.Cells(S, "A") Then Cells(R, "C") = Sheet3.Cells(S, "D") Cells(R, "D") = Sheet3.Cells(S, "E") End If End If Next Next MsgBox "Êã ÇáÊÑÍíá ÈäÌÇÍ " Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله تفضل استدعاء بيانات على اساس اسم الصنف.rar

السلام عليكم ورحمة الله انسخ الكود التالى والصقه فى الموديل الموجود بالملف وخصص له زر فى الصفحة التى تريد ارسال البيانات اليها Sub TransF() Dim x As Variant, LR As Long, LS As Long, R As Integer, y As Range, z As Integer LR = sheet1.Range("B" & Rows.Count).End(xlUp).Row LS = Range("B" & Rows.Count).End(xlUp).Row Range("D8:F" & LR).ClearContents Set y = sheet1.Range("B8:E" & LR) For R = 8 To LS For z = 2 To 4 x = Application.VLookup(Range("B" & R), y, z, 0) Cells(R, z + 2) = x Next Next End Sub

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

السلام عليكم ورحمة الله اضغط (CTRL+SHIFT+ENTER) وذلك بعد تحديد الخلية الاولى لعمود التاريخ

السلام عليكم ورحمة الله اليك الملف بالمعادلات وبدون اكواد HELP.rar

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

السلام عليكم ورحمة الله انسخ هذا الكود فى موديول جديد وخصص له زر Sub LoopDt() For Each C In Range("B9:B15") For Each F In Range("A2:P4") If C.Value = F.Value Then x = F.Offset(0, 1).Value y = WorksheetFunction.Max(x) If x = y Then C.Offset(0, 1) = F.Offset(0, 2) C.Offset(0, 2) = F.Offset(0, 3) C.Offset(0, 3) = F.Offset(0, 1) End If End If Next Next End Sub اعد كتابة بعض اسماء السلع مرة اخرى حتى يعمل معك الكود بكفاءة هذا وبالله التوفيق

السلام عليكم ورحمة الله ادرج هذا الكود بدلا من الكود الموجود Sub CmdInsertRw() Dim lRow As Long Dim lRsp As Long On Error Resume Next lRow = Application.InputBox(Prompt:="ادخل رقم الصف المراد ادخال الصف بعده", _ Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1) lRsp = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & 1, _ Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1) If lRsp = False Then Exit Sub Rows(lRow).Select Selection.Copy Rows(lRsp).Selec Selection.Insert Shift:=xlDown Rows(lRow + 1).PasteSpecial xlPasteFormulasAndNumberFormats Application.CutCopyMode = False End Sub وغير المعادلة الموجودة فى ( A3 ) الى ( A3 - 1 = )

كل التقدير و الاحترام لاستاذنا الكبير الاستاذ / رجب و هذا ايضا كود آخر يؤدى المطلوب دفعة واحدة Sub Looping1() Dim Arr As Variant, i As Integer, Lp As String, Fl As Variant Lr = Sheet1.UsedRange.Rows.Count Arr = Sheet1.Range("A2:F" & Lr) For y = 1 To UBound(Arr, 2) For i = 1 To UBound(Arr, 1) If Arr(i, y) <> "" Then p = p + 1 Lp = Arr(i, y) Fl = Split(Lp, " ") Cells(p + 1, 10) = Fl End If Next Next End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول جديد وخصص له زر Sub Collection() For R = 2 To Range("A" & Rows.Count).End(xlUp).Row Z = "" For Each C In Range("A" & R & ":F" & R) If C <> "" Then Z = Z & C.Value & "-" End If Next Range("K" & R) = Mid(Z, 1, Len(Z)) Next End Sub

السلام عليكم ورحمة الله اتمنى من الله عز وجل ان يكون هذا هو المطلوب ترحيل ناجح وراسب.rar

السلام عليم ورحمة الله اكتب المعادلتين التاليتين كل واحدة فى خلية =COUNTIF($H$3:$H$30;"ثانوي ") =COUNTIF($H$3:$H$30;"متوسط")