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

السلام عليكم ورحمة الله اخى الكريم اليك ملف الصف الثانى كما وعدتك يؤسفنى انه يضم شعبتين فقط هما ( شعبة الادارة و شعبة القانون ) لانه مصمم حسب نظام المدرسة عندنا ان شاء الله تتحسن الظروف و استطيع اضافة الشعبتين الاخرتين اليك ملف الصف الثانى ثانية.xlsm

السلام عليكم ورحمة الله اخى الكريم او ولدى الحبيب اختر ما شئت لقد احلت الى المعاش هذا العام ولكنى قمت بالتعديل على الملف الذى رأيته فى احدى مشاركاتى السابقة وتطويره للافضل ان شاء الله اليك الملف و انا على استعداد لاى تساؤل او استغسار جارى ان شاء الله العمل على تطوير كنترول الصف الثانى و ان شاء الله سأرسله على نفس هذا الموضوع اليك ملف الصف الاول ( حجم الملف يزيد عن 1 ميجا ) هذا وبالله التوفيق اولى.xlsm

السلام عليكم ورحمة الله تفضل لا تنسى وضع زر خروج لليوزر فورم حتى لا تضطر لاغلاق الملف بأكمله Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function BringWindowToTop Lib "user32.dll" (ByVal hWnd As Long) As Long Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Dim hWnd As Long Private Sub UserForm_Initialize() On Error Resume Next Dim lngWindow As Long, lFrmHdl As Long lFrmHdl = FindWindow(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) End Sub

السلام عليكم ورحمة الله جرب هذه المعادلة =IFERROR(INDEX('1'!$B$2:$L$3;1;MATCH(B2;'1'!$B$3:$L$3;0));"")

السلام عليكم ورحمة الله استخدم هذا الكود Sub SaveFile() Dim fname As String Dim path As String fname = Range("A1").Value path = Application.ActiveWorkbook.path If True Then Application.ActiveWorkbook.SaveAs Filename:=path & "\" & fname, _ FileFormat:=xlOpenXMLWorkbook , CreateBackup:=False End If End Sub

السلام عليكم ورحمة الله استخدم هذا الكود بدلا من الكود السابق Sub sort() Range("b3:f24").Select Selection.sort Key1:=Range("D3"), Order1:=xlDescending, Key2:=Range("e3"), Order2:=xlAscending Dim C As Range, x As Integer For Each C In Range("D3:D24") x = WorksheetFunction.Rank(C, Range("D3:D24")) If C.Offset(-1, 0) = C.Value Then C.Offset(0, 3) = x + 1 Else C.Offset(0, 3) = x End If Next Range("b3").Select End Sub

السلام عليكم ورحمة الله استخدم المعادلة التالية و لا تنسى الضغط على CTRL+SHIFT+ENTER =IFERROR(INDEX($C$5:$E$34;MATCH((C2&D2);$C$5:$C$34&$D$5:$D$34;0);3);"")

السلام عليكم ورحمة الله استخدم الكودين الآتيين الكود الاول : Private Sub ComboBox1_Change() Dim ws As Worksheet, Rng As Range Dim MyArray, x As String x = Me.ComboBox1.Value On Error Resume Next Set ws = Sheets(x) Set Rng = ws.Range("A4:I" & ws.Range("B" & Rows.Count).End(xlUp).Row) With Me.ListBox1 .Clear .ColumnHeads = False .ColumnCount = Rng.Columns.Count MyArray = Rng .List = MyArray .ColumnWidths = "150;120;120;120;120;120;120;120" .TopIndex = 0 End With End Sub الكود الثانى : Private Sub UserForm_Initialize() Me.ComboBox1.AddItem "TANKS" Me.ComboBox1.AddItem "TRAINS" Me.ComboBox1.AddItem "FLOW LINE" Me.ComboBox1.AddItem "PUMPS" End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub ImportData() Dim ws As Worksheet, Sh As Worksheet Dim i As Integer, x As Integer, day As String Set ws = Sheets("التقرير اليومي") Set Sh = Sheets("بيانات") day = ws.Range("G4").Value ws.Range("E107:L151").ClearContents For i = 19 To 67 Step 12 If Sh.Cells(3, i).Value = day Then x = i + 7 Sh.Activate Sh.Range(Cells(5, i), Cells(49, x)).Copy ws.Activate ws.Range("E107").PasteSpecial xlPasteValues ws.Range("E105") = day End If Next ws.Range("G4").Select Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله اليك الملف جاهز تفضل ورقة عمل Microsoft Excel جديد ‫‬.rar

السلام عليكم ورحمة الله ضع هذا العبارة بآخر شطر بالكود msgbox "تم الترحيل بنجاح"

السلام عليكم ورحمة الله استخدم هذا الكود الضغط على زر الترحيل مرة واحدة حتى لا تتكرر عملية الترحيل Sub TrasfData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long Set ws = Sheets("البيانات") Set Sh = Sheets("امر صرف") LR = ws.Range("B" & Rows.Count).End(xlUp).Row If LR < 2 Then LR = 2 Else LR = LR ws.Range("B" & LR + 1).Value = Sh.Range("G5").Value ws.Range("C" & LR + 1).Value = Sh.Range("D5").Value ws.Range("D" & LR + 1).Value = Sh.Range("I2").Value ws.Range("A" & LR + 1).Value = LR - 1 End If End Sub

السلام عليكم ورحمة الله اخى الكريم اليك شرح الكود و الله الموفق و المستعان ' وقف اهتزاز الشاشة اثناء تنفيذ الماكرو Application.ScreenUpdating = False ' تعريف الورقة الهدف Set ws = Sheets("الاخلاء") ' التعريف بورقة المصدر Set Sh = Sheets("المدرسين") ' طول البيانات فى ورقة المصر ( آخر صف ) LR = Sh.Range("C" & Rows.Count).End(xlUp).Row ' رقم الكشف المراد استدعاؤه z = ws.Range("O2").Value ' اهم نقطة فى الكود تم البدء برقم سالب حتى نتمكن من البدء يالصف الثامن j = -4 ' لتحديد اول رقم يتم جلبه x = (z - 1) * 4 + 1 ' تحديد آخر رقم يتم جلبه y = z * 4 ' حلقة تكرارية تبدأ من الصف الرابع للبيانات التى سوف يتم جلبها For i = 4 To LR ' شرط استدعاء البيانات بالارقام المحصورة بينها If Sh.Cells(i, "B") >= x And Sh.Cells(i, "B") <= y Then ' تسلسل البيانات المستدعاة بورقة الهدف j = j + 12 ' تسكين البيانات فى المواضع المطلوبة ws.Cells(j, "E") = Sh.Cells(i, "D") ws.Cells(j, "J") = Sh.Cells(i, "C") ws.Cells(j + 1, "E") = Sh.Cells(i, "E") End If Next i ' اعادة خاصية اهتزازات الشاشة Application.ScreenUpdating = True

السلام عليكم ورحمة الله استخدم الكود الاول فى موديول عادى Sub PrintEW() Dim R As Integer, ws As Worksheet Set ws = Sheets("الاخلاء") For R = 1 To ws.Range("O3").Value R = Range("O2").Value ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False Range("O2").Value = R + 1 Next R End Sub اما الكود الثانى فضعه فى حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$O$2" Then Exit Sub Call EndWork End Sub

السلام عليكم ورحمة الله اخى الكريم احمد اشكرك على هذا الملحوطة الهامة اليك الملف بعد التعديل اخلاء طرف.xls

السلام عليكم ورحمة الله ربما يفيدك هذا اخلاء طرف.xls

السلام عليكم ورحمة الله اكتب الكود الاول فى موديول عادى اما الكود الثانى فضعه فى حدث ولرقة العمل Sub SortData() Range("C2:E" & Range("D" & Rows.Count).End(xlUp).Row).Sort key1:=Range("E2"), _ order1:=xlDescending, key2:=Range("D2"), order2:=xlAscending End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 5 Then Call SortData End If End Sub

السلام عليكم ورحمة الله استخدم الكود الاول لالغاء الفلترة و الكود الثانى لفلترة عمود الليرة و لديك بالفعل كود بمشاركتى الاولى لفلترة عمود الدولار ... هذا على حسب ما فهمت Sub UndoHidden() ActiveSheet.Rows.EntireRow.Hidden = False End Sub Sub FilterNonEmptyRows2() Dim R As Range For Each R In Range("E3:E" & Range("B" & Rows.Count).End(xlUp).Row) If R.Value = "" And R.Offset(0, 1).Value = "" Then R.EntireRow.Hidden = True End If Next End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub FilterNonEmptyRows() Dim C As Range For Each C In Range("C3:C" & Range("B" & Rows.Count).End(xlUp).Row) If C.Value = "" And C.Offset(0, 1).Value = "" Then C.EntireRow.Hidden = True End If Next End Sub

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF($D$1=65;COUNTIF(G3:G13;"<40");COUNTIF(G3:G13;"<30"))

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF(F3="";"";IF(OR(AND($D$1=50;G3:K3>=30);AND($D$1=65;G3:K3>=40));"ناجح";"دون المستوى")) ثم اضغط على المفاتيح التالية قبل السحب نزولا Ctrl + Shift + Enter

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF(OR(AND($D$1=50;G3<30);AND($D$1=65;G3<40));"عربى/";"")

السلام عليكم ورحمة الله تفضل المصنف1.xlsx

السلام عليكم ورحمة الله جرب هذا الكود Sub ReSerial() Dim Ws As Worksheet Dim LR As Long, i As Long, x As Long Set Ws = Sheets("data1") LR = Ws.Range("A" & Rows.Count).End(xlUp).Row For i = 11 To LR x = i Mod 10 If x = 0 Then x = x + 10 If Cells(i, 1) <> "" Then Cells(i, 2) = x End If Next End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Sparate_Result() Dim ws As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet Dim Succ As String, Fail As String Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long, q As Long Application.ScreenUpdating = False Set ws = Sheets("نتيجة آخر العام ") Set Sh1 = Sheets("ناجح1") Set Sh2 = Sheets("دور ثان2") Sh1.Range("H6:AI110").ClearContents Sh1.Range("H6:AI110").ClearContents Succ = "ناجح" Fail = "دور ثان" Arr = ws.Range("B6:AI110").Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 33) = Succ Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Sh1.Range("B6").Resize(p, UBound(Temp, 2)).Value = Temp ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 33) = Fail Then q = q + 1 For j = 1 To UBound(Arr, 2) Temp(q, j) = Arr(i, j) Next End If Next If q > 0 Then Sh2.Range("B6").Resize(q, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub