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

السلام عليكم ورحمة الله جرب هذه المعادلة =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

السلام عليكم ورحمة الله جرب هذه المعادلة =LEFT(YEAR(D2);1)+1&RIGHT(YEAR(D2);2)&IF(LEN(MONTH(D2))=1;"0"&MONTH(D2);MONTH(D2))&IF(LEN(DAY(D2))=1;"0" &DAY(D2);DAY(D2))&C2

السلام عليكم ورخمة الله استخدم المعادلة التالية =COUNTIF(A2:A9;"<>"& 0)

السلام عليكم ورحمة الله جرب الكود بعد التعديل ربما يكون هذا مقصدك Sub ImportData1() Application.ScreenUpdating = False Dim wbBook1 As Workbook, wbBook2 As Workbook Dim Path As String Dim Arr As Variant, i As Long, x As Long, LR As Long, LS As Long Dim a As String, b As String, d As String Sheets("Get").Range("B7:J" & Sheets("Get").Range("E" & Rows.Count).End(xlUp).Row).ClearContents Set wbBook1 = ThisWorkbook Path = wbBook1.Path & "\" Arr = Array("DATA1", "DATA2") For x = LBound(Arr) To UBound(Arr) Set wbBook2 = Workbooks.Open(Path & Arr(x) & ".xlsm") Dim wsSheet1 As Worksheet Dim wsSheet2 As Worksheet Set wsSheet1 = wbBook1.Worksheets("Get") a = wsSheet1.Range("E1").Value b = wsSheet1.Range("E2").Value d = wsSheet1.Range("E3").Value Set wsSheet2 = wbBook2.Worksheets("Data") LR = wsSheet2.Range("E" & Rows.Count).End(xlUp).Row LS = wsSheet2.Cells(6, Columns.Count).End(xlToLeft).Column For i = 3 To LR Step 1 If Trim(wsSheet2.Range("B" & i)) = Trim(a) And _ Trim(wsSheet2.Range("E" & i)) = Trim(d) And _ Trim(wsSheet2.Range("J" & i)) = Trim(b) Then p = p + 1 wsSheet1.Range("C" & p + 6).Resize(, LS).Value = wsSheet2.Range("C" & i).Resize(p, LS).Value wsSheet1.Range("B" & p + 6) = p End If Next wbBook2.Close True Next Application.ScreenUpdating = True End Sub