نجوم المشاركات

السلام عليكم *********** طاب يومكم بكل خير وحفظكم ربى الطلب لاحد الاعضاء وهو كيف يتم تطبيق دالة F لاكثر من 9 شروط اليكم المرفق ب 14 شرط وثلاث تطبيقات مختلفة لاتحرمونا من دعائكم دالة IF لاكثر من 14 شرط.rar

يعطيكم العافيه عندي ايميل الموقع الخاص بي شابكه علي الجي ميل 1-قبل فتره فعلت خدمة الاوتلوك سويت تزامن وسحب الايميلات من الجي ميل ومسحهم و سوا نسخه منه علي الاوت لوك كيف اخليه يحتفظ بالنسخ ومايحذفه وتصير نسخه علي الاوتلوك ونسخه علي الجي ميل 2-الان بعد ما الغيت التزامن علي الاوت لوك الايميلات الجديد فقط هي علي الجي ميل كيف اسوي استرجاع للايميلات القديمه من الاوتلوك الى الجميل مع العلم الاوتلوك اصدراه 2007

السلام عليكم أخي الكريم ضع الكود التالي في حدث الورقة 3 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$C$2" Then Exit Sub [B4:E999].ClearContents sel = [C2] With Sheet2 LR = .[C9999].End(xlUp).Row .Range("B2:F" & LR).AutoFilter Field:=4, Criteria1:=sel nLR = .[C9999].End(xlUp).Row .Range("C2:D" & nLR & ",F2:F" & nLR).Copy .AutoFilterMode = False End With [B4].PasteSpecial Paste:=xlPasteValues LR = [D9999].End(xlUp).Row Range("D4:D" & LR).Cut [C4].Insert Shift:=xlToRight [A4:D4].Delete Shift:=xlUp LR = LR - 1 If LR < 5 Then Exit Sub For r = 4 To LR For nr = r + 1 To LR If Cells(nr, 2) = Cells(r, 2) Then Range("C" & nr & ":D" & nr).Copy Cells(r, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Range("B" & nr & ":D" & nr).Delete Shift:=xlUp End If Next nr Next r End Sub

السلام عليكم تم استخدام الكود التالي Option Explicit Private Const ContColmn As Integer = 3 '====================================================== '====================================================== Sub kh_Report() Dim obj As Object Dim x(), AryList() Dim iKey As String Dim iTm As Range, Rng As Range Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long Dim c As Integer Dim v1 As Double, v2 As Double '============================================ Set obj = CreateObject("Scripting.Dictionary") '============================================ With Cells.Worksheet LastRow = .Cells(Rows.Count, "B").End(xlUp).Row With .Range("B4") .Activate .Resize(1, ContColmn).ClearContents .Offset(1, 0).Resize(LastRow, ContColmn).Clear End With End With '============================================ With ورقة2 LastRow = .Cells(Rows.Count, "C").End(xlUp).Row Set Rng = .Range("C3:C" & LastRow) End With '============================================ On Error GoTo kh_Ex '============================================ For Each iTm In Rng If CStr(iTm.Cells(1, 3)) = CStr(Range("C2")) Then iKey = iTm.Value v1 = Val(iTm.Cells(1, 4)) v2 = Val(iTm.Cells(1, 2)) ''''''''''''''''''' If obj.exists(iKey) Then iii = obj(iKey) '''''''''''''''''' x(2, iii) = Val(x(2, iii)) + v1 x(3, iii) = Val(x(3, iii)) + v2 Else ii = ii + 1 ReDim Preserve x(1 To ContColmn, 1 To ii) obj.Add iKey, ii '''''''''''''''''' x(1, ii) = iKey x(2, ii) = v1 x(3, ii) = v2 End If End If Next '============================================ iCont = obj.Count If iCont Then ReDim AryList(1 To iCont, 1 To ContColmn) For i = 1 To iCont '''''''''''''''''' For c = 1 To 3 AryList(i, c) = x(c, i) Next '''''''''''''''''' Next '============================================ With Range("B4").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = AryList End With ''''''''''''''''''''''''' End If '============================================ kh_Ex: '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else If iCont Then MsgBox "تم تحديث التقرير بنجاح ", vbMsgBoxRight, "الحمدلله" End If '''''''''''''''''' Set obj = Nothing Set Rng = Nothing Erase x, AryList '''''''''''''''''' End Sub شاهد المرفق 2003 تصفية وتجميع.rar

أخى العزيز تم عمل المطلوب بالدالة Rank tartib.rar ويمكن ايضا ان تراجع هذا الرابط لعله يفيدك http://www.officena.net/ib/index.php?showtopic=48747&hl=

السلام عليكم أخي الكريم بالمرفق محاولة مبدئية لضيق الوقت وضعت بيانات وهمية في الـ 26 ملف (RAND) الكود مؤقتا يعتمد علي أن الملفات كلها إسمها Data file n.xls والبيانات في كل شيت 10 أسطر فقط تفضل Data file.rar

السلام عليكم أخي الفاضل / shakhawan تفضل المرفق توزيع التلاميذ3.rar

الملف على موقع http://www.gulfup.com/ كما امر استاذى حمادة عمر http://www.gulfup.com/?Mkfdk8