عبدالله باقشير

السلام عليكم ورحمة الله اخي بن عليه شاهد المرفق bmt3.rar

السلام عليكم استخدم المعادلة: =IF(SUBTOTAL(3;F5:F19)=COUNTA(F5:F19);"";VLOOKUP(SUBTOTAL(4;A5:A19);A5:F19;6;0)) تفضل المرفق العميل.rar

السلام عليكم استخدم المعادلة التالية: =IF(SUBTOTAL(3;D2:D18)=COUNTA(D2:D18);"الكل";IF(SUBTOTAL(4;B2:B18)=SUBTOTAL(5;B2:B18);VLOOKUP(SUBTOTAL(4;B2:B18);B2:C18;2;0);"###")) وقد استخدمت رقم كود لكل اسم شاهد المرفق HH3.rar

السلام عليكم يارك الله فيك اخي هشام استخدم المعادلة التالية: =IF(SUBTOTAL(3;D2:D11)=COUNTA(D2:D11);"الكل";VLOOKUP(SUBTOTAL(4;B2:B11);B2:C11;2;0)) شاهد المرفق HH1.rar

السلام عليكم استخدمنا المعادلة التالية: =SUMPRODUCT((TEXT(INDEX(myrng;0;1);"m/yy")=C$2)*(INDEX(myrng;0;8)=$B6)*(INDEX(myrng;0;C$1))) مع اضافة معادلات مساعدة في الصفين 1و2 من شيت REPORT من اجل استخدام نفس المعادلة للكل تفضل المرفق REPORT.rar

السلام عليكم استخدم معادلة الصفيف التالية =MIN(IF(INDEX(myrng;0;1)=$A2;INDEX(myrng;0;2);"")) واضغط F2 لتحرير الصيغة، ثم اضغط CTRL+SHIFT+ENTER لادخال صيغة الصفيف تفضل المرفق 2007 اكبر واصغر قيمة بشرط.rar وده مرفق 2003 لاخي ايسم اكبر واصغر قيمة بشرط.rar

الاخ الحبيب/ الخالدي و

و

السلام عليكم شيت 1 و 2 اعملي معادلة في العمود A لارجاع التسلسل =ROW()-1 اما الشيت 3 فتم تعديل الكود استدعاء بيانات من اوراق معينة مع حذف المرحل.rar

السلام عليكم تم اضافة زر للمسح وبعض التعديلات لكود الاضافة Option Explicit '****************************************************** ' تعيين نطاق الخلايا التي يتم نسخها Private Const MyRng_Copy As String = "B4:I4" '------------------------------------------------------ ' MyRng_Copy تعيين رقم العمود من النطاق ' الذي سياخذ منه آخر صف للصق Private Const MyColumn As Integer = 4 '****************************************************** Sub Kh_Insert_Rows() On Error Resume Next Dim MyRow As Integer, LastRow As Integer MyRow = 1 MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & MyRow, Title:="ادراج عدد محدد من صفوف ", Default:=MyRow, Type:=1) If MyRow = False Then Exit Sub With Range(MyRng_Copy) LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count If LastRow = 0 Then LastRow = 1 .Copy With .Offset(LastRow, 0).Resize(MyRow, .Columns.Count) .PasteSpecial xlPasteAll .SpecialCells(xlCellTypeConstants).ClearContents End With .Columns(1).Offset(LastRow, 0).Select End With Application.CutCopyMode = False MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله" On Error GoTo 0 End Sub ------------------------------------------------------------------- Sub Kh_Clear_Rows() On Error Resume Next Dim LastRow As Integer With Range(MyRng_Copy) LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count .SpecialCells(xlCellTypeConstants).ClearContents If LastRow = 0 Then GoTo 1 .Cells(2, 1).Resize(LastRow, .Columns.Count).Clear End With 1: MsgBox "تم المسح بنجاح", 524288 + 1048576, "الحمدلله" On Error GoTo 0 End Sub ادراج صفوف لاسفل بنفس والمعادلات التنسيق.rar

السلام عليكم ملحوظة : لمن حمل الملف قبل المشاركة هذه يقوم بتحميل الملف مرة اخرى لانني في الملف السابق نسيت ان اربط الثابت MyRng_Copy بالخلايا داخل الكود اويعدل السطر With Range("B4:I4") بهذا With Range(MyRng_Copy) تقبلوا تحياتي وشكري

السلام عليكم ورحمة الله وبركاته بارك الله فيك اخي كنافة Option Explicit '****************************************************** ' تعيين نطاق الخلايا التي يتم نسخها Private Const MyRng_Copy As String = "B4:I4" '------------------------------------------------------ ' MyRng_Copy تعيين رقم العمود من النطاق ' الذي سياخذ منه آخر صف للصق Private Const MyColumn As Integer = 4 '****************************************************** Sub Kh_Insert_Rows() On Error Resume Next Dim MyRow As Integer, LastRow As Integer MyRow = 1 MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & MyRow, Title:="ادراج عدد محدد من صفوف ", Default:=MyRow, Type:=1) If MyRow = False Then Exit Sub With Range(MyRng_Copy) LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count .Copy With .Offset(LastRow, 0).Resize(MyRow, .Columns.Count) .PasteSpecial xlPasteAll .SpecialCells(xlCellTypeConstants).ClearContents End With .Columns(1).Offset(LastRow, 0).Select End With Application.CutCopyMode = False MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله" On Error GoTo 0 End Sub ادراج صفوف لاسفل بنفس والمعادلات التنسيق.rar

السلام عليكم Sub kh_tr_2() Dim X As Range Dim C As Byte, CC As Byte Dim IRow As Integer IRow = 2 IRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & IRow, Title:="ادراج عدد محدد من صفوف ", Default:=IRow, Type:=1) If IRow = False Then Exit Sub Sheets("KH").Cells.ClearContents For C = 1 To 9 CC = Choose(C, 1, 2, 3, 6, 7, 8, 13, 17, 18) With Range("A1:X" & IRow) If X Is Nothing Then Set X = .Columns(CC) Else _ Set X = Union(X, .Columns(CC)) End With Next If Not X Is Nothing Then X.Copy Sheets("KH").Select Range("A1").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("A1").Select End If End Sub شاهد المرفق ترحيل مدى غير متجاور.rar

وعليكم السلام نعم بس ضبط المعلومات في اول الكود تمام '====================================================== ' اول صف للتقرير Private Const iRow As Integer = 4 '------------------------------------------------------ ' اسم ورقة التقارير Private Const Sh_Report As String = "التقرير" '------------------------------------------------------ ' اسم ورقة البيانات Private Const Sh_MyDate As String = "بيانات اساسية" '------------------------------------------------------ ' تعيين نطاق الخلايا في ورقة البيانات ' ويشمل رؤوس الاعمدة Private Const MyRng_MyDate As String = "A5:X1000" '======================================================

السلام عليكم Union غرض Range يمثل اجتماع مجموعة نطاقات متجاورة او غير متجاورة

السلام عليكم لو ترفق ملف وتشرح لي ماذا تريد بالضبط بيكون احسن ولكن جرب هذا الكود Sub kh_tr_2() Dim X As Range Dim C As Byte, CC As Byte Dim IRow As Integer IRow = 50 Sheets("KH").Cells.ClearContents For C = 1 To 9 CC = Choose(C, 1, 2, 3, 6, 7, 8, 13, 17, 18) With Range("A1:X" & IRow) If X Is Nothing Then Set X = .Columns(CC) Else _ Set X = Union(X, .Columns(CC)) End With Next If Not X Is Nothing Then X.Copy Sheets("KH").Select Range("A1").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("A1").Select End If End Sub

السلام عليكم Option Explicit Sub Kh_Sh_Name_Data() Dim S For Each S In Array("Sheet1", "Sheet2") Kh_Call_Data CStr(S) Next End Sub --------------------------------- Sub Kh_Call_Data(Sh_Name As String) Dim X As Range Dim r As Integer, n As Integer n = Range("A10000").End(xlUp).Row With Worksheets(Sh_Name) For r = 2 To .Range("A10000").End(xlUp).Row If .Range("A" & r).Interior.ColorIndex = 6 Then n = n + 1 Range("A" & n).Resize(1, 3).Value = .Range("A" & r).Resize(1, 3).Value If X Is Nothing Then Set X = .Rows(r) Else _ Set X = Union(X, .Rows(r)) End If Next End With If Not X Is Nothing Then X.Delete End Sub يمكنك تغيير اسماء الاوراق المستدعى منها البيانات او اضافة اسماء اخرى بجانب الموجود في السطر الثالث هنا Array("Sheet1", "Sheet2") خبور خير استدعاء بيانات من اوراق معينة مع حذف المرحل.rar

السلام عليكم لا تتشابك عليك المعلومات هذا في حالة ربط القيمة خلايا معينة=خلايا معينة اما في حالة النسخ واللصق نحتاج الى خلية واحدة للصق Sub kh_tr_1() Sheets("KH").Cells.ClearContents Range("A1:C100,F1:H100,M1:M100,Q1:R100").Copy Sheets("KH").Select Range("A1").PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم الافتباس من الرابط التالي المشاركة 8 http://www.officena.net/ib/index.php?showtopic=32960

السلام عليكم نفذت المطلوب بالكود بتوفيق من الله بعد جهد متواصل الان الملف يعمل بسهولة ولكن لو يتم ابعاد الاعمدة الغير مستخدمة ويعيد تنظيم الورقة بشكل انيق يامكاننا تحديد المطلوبات في بداية الكود المهم الان وصلنا الى الحل وابعاد تلك المعادلات الطويلة وقد استخدمت الاعمدة AA:AD فارجوا عدم استخدامها Option Explicit Sub Kh_Top_ten_students() Dim R As Integer, RR As Integer, XX As Integer Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Range("D8:J17").ClearContents With Range("data1") For R = 1 To .Rows.Count If .Cells(R, 2) <> 0 Then If .Cells(R, [R8]) >= 50 Then If [K5] = [V9] Then RR = RR + 1 KH_Copy_value R, RR Else If [K5] = .Cells(R, 13) Then RR = RR + 1 KH_Copy_value R, RR End If End If End If End If Next R End With Range(Range("AA1:AD1"), Range("AA1:AD1").End(xlDown)).Sort Range("AC1"), xlDescending For XX = 1 To 10 If Not IsEmpty(Range("AA" & XX)) Then Range("D" & XX + 7).Resize(1, 3).Value = Range("AA" & XX).Resize(1, 3).Value Range("G" & XX + 7).Formula = "=Kh_RANK(RC6,R8C6:R17C6,""مكرر"")" Range("I" & XX + 7) = Range("AD" & XX) End If Next Range("AA1:AD1000").Clear Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Function KH_Copy_value(iR As Integer, iRR As Integer) With Range("data1") Cells(iRR, "AA") = .Cells(iR, 2) Cells(iRR, "AB") = .Cells(iR, 3) Cells(iRR, "AC") = .Cells(iR, [R8]) Cells(iRR, "AD") = "'" & .Cells(iR, 13) End With End Function تفضلوا المرفق ترتيب العشرة الاوائل بالكود.rar

السلام عليكم اخي كيماس كودك ممتاز ولكن ممكن نعدل فيه بعض الشي ان اردت ذلك ؟؟ وجمعة مباركة للجميع ودمتم في حفظ الله خبور خير

هنا يتم التغيير '****************************************************** ' اسم ورقة البيانات Const Sh_MyDate As String = "all" '------------------------------------------------------ ' رقم صف رؤوس الاعمدة Const lrow As Integer = 3 '------------------------------------------------------ ' عدد الاعمدة التي تريدها ابتداءا من العمود الاول Const lcol As Integer = 60 '****************************************************** اما كود نقل الصور اخذناها من ملف للاخ الحبيب ابو عبدالله اكسيلجي و لا اريد اسئلة عن هذا الكود لاني انا نفسي لا اعرف آلية عمل هذا الكود شاهدي المرفق اخي كيماس الان بنراجع الكود بتاعك المرتبات مع الصور1.rar

السلام عليكم هذا يجعل حساب المعادلات يدويا Application.Calculation = xlCalculationManual وهذا يجعله تلقائيا Application.Calculation = xlCalculationAutomatic شاهد المرفق فيديو يوضح تسجيل ماكرويجعل الحساب يدويا ثم تسجيل ماكرو آخر لجعل الحساب تلقائيا Calculation.rar

هذا الجزئية ليس لها علاقة بالخلايا في الشيت من مسح اوغيره وهي تخص التاكست بوكس لتجعله للمعاينة فقط ( لايمكن التعديل فيه) وتاخذ شرط انها للمعاينة من الخلايا اللي في الصف الرابع (اذا كانت فيها معادلات ) -------------- اما شرط تجاوز التعديل في الخلايا اللي فيها معادلات نحتاجه في زر حفظ التغييرات هنا: For j = 1 To lcol If Me.Controls("Textbox" & j).Locked = False Then Worksheets(Sh_MyDate).Cells(k + 3, j) = Me.Controls("Textbox" & j).Value End If Next j توسعنا في الشرح هنا لاحتياجنا لمثل هذا في اعمال اخرى خبور خير

============================= ملحوظة : ============================= عندما تقوم بنسخ كود فيه كلمات باللغة العربية حول اللغة الى العربي في الاكسل قبل النسخ ثم قم بنسخها ولصفها هنا ستظهر حبنها باللغة العربية وليست طلاسم مثل كودك اعلاه =============================