سليم حاصبيا

لا حاجة للكود في هذه الحالة يكفي المعادلة التالية في الخلية DC24 و سحيها يساراً ثم نزولاً =IFERROR(INDEX($A$24:$CX$500,ROWS($A$1:A1),MATCH(DC$21,$A$23:$CX$23,0)),"")

استبدل الكود يهذا (اذا كان ما فهمته صحيحاً) Option Explicit Sub OFFICNA_Values() Dim LR As Long, ws As Worksheet, ws2 As Worksheet Dim Num, s% Set ws = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") If Not IsNumeric(ws.Range("c1")) _ Or ws.Range("c1") = vbNullString Then Num = 1 Else Num = Int(Abs(ws.Range("c1"))) End If Select Case Num Case 1 s = 0 Case Else s = 2 * Num - 1 End Select s = IIf(s > 1, s - 1, s) LR = ws.Range("a" & Rows.Count).End(xlUp).Row If ws.Range("a2").Value = "" Then MsgBox ("No Data to transfere ") Exit Sub Else ws.Range("a2").Resize(LR - 1, 2).Copy ws2.Range("a2").Offset(, s).PasteSpecial Paste:=xlPasteValues End If Application.CutCopyMode = False End Sub الملف مرفق Posting_salim.xlsm

اخي علي للمزيد هذا الملف حول هذا الموضوع تصحيح معادلة-Using define Name.xlsx

زيادة في اثراء الموضوع هذه المعادلة =IF(NOT(N(SUMPRODUCT(--($A2:$K2>50))+SUMPRODUCT(--($A2:$K2="ت"))+SUMPRODUCT(--($A2:$K2="غ")))),"",SUMPRODUCT(--($A2:$K2>50))+SUMPRODUCT(--($A2:$K2="ت"))+SUMPRODUCT(--($A2:$K2="غ")))

لم ار اي عينة من الخلية في الطلب الأول اين الخلية و ما عنوانها و محتوياتها

هذه المعادلة =SUMPRODUCT(--($A2:$K2>50))+SUMPRODUCT(--($A2:$K2="ت"))+SUMPRODUCT(--($A2:$K2="غ"))

ارفع الملف للمعاينة

ارفع الملف للمعاينة

By formula استدعاء.xls

salim نجاح.xls

salim Control.xlsm

قبل كل شيء يجب ازالة عدو الاكواد الاول (اعني دمج الخلايا) حتى الكود يعطي النتيجة المطلوبة

بالنسبة الى توسيع المدى فان الكومبو بوكس يتسع الى 500 اسم و يمكن الزيادة (كلما اضفت اسماُ يظهر اوتوماتيكياُ في الكومبو) (مسألة الادارة والمدرسة هذه امور ثابتة يمكن اضافتها بدون معادلات) بالنسية للطباعة ليس صعباً طباعة الصفحة يشكل عادي (اضغط فقط Ctrl +P)

معادلة بسيطة تكتب في الخلية B2 و تسحب حتى الخلية B13 =IF(ISNA(MATCH(A2,$A$16:$A$500,0)),"",INDEX($B$16:$B$500,MATCH(A2,$A$16:$A$500,0))) الملف مرفق TESTsalim.xlsx

جرب هذا الشيء salimبيان نجاح.xls

جرب هذا الملف Crazy_Sort.xlsm

هذه المعادلة في الخلية B15 و تسحب نزولاً =OFFSET(INDEX($A$1:$O$1,MATCH($A$12,$A$1:$O$1,0)),$B$14+1,ROWS($A$1:A1),)

ريما كان المطلوب Mowazana.xlsx

الملف الذي رفعته مضروب بفيروس و قد رفض الجهاز فتحه ومع ذلك فقد وضعت لك ملفاُ شبيهاً (مع مساحة أقل على الذاكرة اي بدون خلايا مدمجة غير لازمة مع طباعة فقط البطاقة) مع المعادلة المطلوبة bitaka.xlsx

لاحظت انا هذا الشيء و قد ورد خظأ بسيط تم تصليحة اعد تحميل الملف مرة احرى الحطأ في هذا السطر (رقم 11 من الاسفل) Sheets("Sapace").Range("a" & k ).Resize(, 4).Value و يجب ان يكون هكذا Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value

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

تم معالحة الامر الكود الجديد Option Explicit Sub filter_ME_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim My_arr(): ReDim My_arr(1 To 4) My_arr(1) = 18: My_arr(2) = 2 My_arr(3) = 3: My_arr(4) = 5 Dim lr%, k%, m%: m = 5 Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات") Dim T_sh As Worksheet: Set T_sh = Sheets("salim") Dim My_Table As Range: Set My_Table = _ S_sh.Range("A4").CurrentRegion T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents With My_Table .AutoFilter .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3") .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2") Sheets("Sapace").Cells.Clear For k = 1 To 4 .Columns(My_arr(k)).SpecialCells(xlCellTypeVisible).Copy _ Destination:=Sheets("Sapace").Range("a1").Offset(, k - 1) Next .AutoFilter End With '====================== lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row For k = 2 To lr Step 2 T_sh.Range("b" & m).Resize(, 4).Value = _ Sheets("Sapace").Range("a" & k).Resize(, 4).Value T_sh.Range("g" & m).Resize(, 4).Value = _ Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value T_sh.Range("a" & m) = k - 1: T_sh.Range("f" & m) = k m = m + 1 Next If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Erase My_arr End Sub الملف مرفق الترحيل salim_modifier .xlsm

يجب كتابة هذه الكلمات (ناجح / راسب/مكمل) في الجدول الاساسي بالضبط كما هي في القائمة المنسدلة دون مسافات ناقصة او زائدة ربما هناك بعض الاخطاء في كتابة بعضها

جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو) الكود Option Explicit Sub filter_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim lr%, k%, m%: m = 5 Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات") Dim T_sh As Worksheet: Set T_sh = Sheets("salim") Dim My_Table As Range: Set My_Table = _ S_sh.Range("A4").CurrentRegion T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents With My_Table .AutoFilter .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3") .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2") Sheets("Sapace").Cells.Clear .Columns(18).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("a1") .Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("b1") .Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("c1") .Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy _ Destination:=Sheets("Sapace").Range("d1") .AutoFilter End With '====================== lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row For k = 1 To lr Step 2 T_sh.Range("b" & m).Resize(, 4).Value = _ Sheets("Sapace").Range("a" & k).Resize(, 4).Value T_sh.Range("g" & m).Resize(, 4).Value = _ Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value T_sh.Range("a" & m) = k: T_sh.Range("f" & m) = k + 1 m = m + 1 If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق الترحيل salim.xlsm

جرب هذا الماكرو Option Explicit Sub Give_Data() Dim first As Worksheet Dim sec As Worksheet Dim third As Worksheet Dim lr1%, lr2%, m%: m = 4 Set first = Sheets("ورقة1") Set sec = Sheets("ورقة11") Set third = Sheets("تجميع") third.Range("b3").CurrentRegion.Offset(1).ClearContents lr1 = Application.Max(first.Range("b:b")) + 3 lr2 = Application.Max(sec.Range("b:b")) + 3 third.Cells(m, 2).Resize(lr1 - 3, 9).Value = _ first.Range("b4").Resize(lr1 - 3, 9).Value m = m + lr1 - 3 third.Cells(m, 2).Resize(lr2 - 3, 9).Value = _ sec.Range("b4").Resize(lr2 - 3, 9).Value End Sub الملف مرفق استدعاء.xlsm