محمد هشام.
-
Posts
1818 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
159
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
مشاركات المكتوبه بواسطه محمد هشام.
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك
Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("RECAP MDN+DGSN"): End Property Private Sub CommandButton1_Click() Const MAX_DAYS As Long = 90 Dim a As Variant, matricule As String, xDate As Date, lastDate As Date Dim i As Long, tmp As Long, trouve As Boolean, jRestants As Long matricule = Trim(Me.TextBox2.Value) If matricule = "" Then MsgBox "المرجو إدخال رقم التسجيل", vbExclamation, "تنبيه": Exit Sub If Not IsDate(Me.TextBox3.Value) Then MsgBox "المرجو إدخال التاريخ", vbExclamation, "خطأ": Exit Sub xDate = CDate(Me.TextBox3.Value): a = WS.Range("B8:C22").Value For i = UBound(a, 1) To 1 Step -1 If Trim(a(i, 1)) = matricule And IsDate(a(i, 2)) Then lastDate = a(i, 2): trouve = True: Exit For Next i If trouve And xDate - lastDate < MAX_DAYS Then jRestants = MAX_DAYS - (xDate - lastDate) MsgBox "يوجد تسجيل سابق بتاريخ: " & Format(lastDate, "dd/mm/yyyy") & vbCrLf & _ "يرجى الانتظار " & jRestants & " يوم قبل التسجيل مجددا", vbExclamation, "تنبيه" Exit Sub End If For i = 1 To UBound(a, 1) If Trim(a(i, 1)) = "" Then tmp = i: Exit For Next i If tmp = 0 Then MsgBox "النطاق ممتلئ لا يمكن إضافة تسجيل جديد", vbCritical, "خطأ": Exit Sub a(tmp, 1) = matricule: a(tmp, 2) = xDate WS.Range("B8:C22").Value = a MsgBox "تمت إضافة التسجيل بنجاح", vbInformation Me.TextBox2.Value = "": Me.TextBox3.Value = "" End Sub '==================== Private Sub CommandButton4_Click() Dim OnRng As Variant, matricule As String, tmps As Date Dim i As Long, supprimé As Boolean matricule = Trim(Me.TextBox2.Value) If matricule = "" Then MsgBox "المرجو إدخال رقم التسجيل لحذفه", vbExclamation, "تنبيه": Exit Sub If Not IsDate(Me.TextBox3.Value) Then MsgBox "المرجو إدخال التاريخ", vbExclamation, "خطأ": Exit Sub tmps = CDate(Me.TextBox3.Value) If MsgBox("هل أنت متأكد من حذف هذا التسجيل؟" & vbCrLf & _ "رقم التسجيل: " & matricule & vbCrLf & _ "تاريخ التسجيل: " & Format(tmps, "dd/mm/yyyy"), _ vbYesNo + vbQuestion, "تأكيد الحذف") = vbNo Then Exit Sub OnRng = WS.Range("B8:C22").Value supprimé = False For i = 1 To UBound(OnRng, 1) If Trim(OnRng(i, 1)) = matricule And IsDate(OnRng(i, 2)) And CDate(OnRng(i, 2)) = tmps Then OnRng(i, 1) = "": OnRng(i, 2) = "": supprimé = True: Exit For End If Next i If supprimé Then WS.Range("B8:C22").Value = OnRng MsgBox "تم حذف التسجيل بنجاح", vbInformation Else MsgBox "لم يتم العثور على التسجيل المطلوب", vbExclamation, "غير موجود" End If Me.TextBox2.Value = "": Me.TextBox3.Value = "" End Sub-
3
-
-
-
4
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
=TEXT((A4-INT(A4))*1000,"000")
-
5
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
جرب هدا
الخلية G2 ضع المعادلة التالية مع سحبها للأسفل
=IFERROR(IF(G$6="قوى", IF(INDIRECT("'"&F$6&"'!L"&ROW()) <>"", INDIRECT("'"&F$6&"'!L"&ROW()), ""), IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!O"&ROW())<>"", INDIRECT("'"&F$6&"'!O"&ROW()), ""), "")),"")الخلية G2
=IFERROR(IF(G$6="قوى",IF(INDIRECT("'"&F$6&"'!M"&ROW()) <>"", INDIRECT("'"&F$6&"'!M"&ROW()), ""),IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!P"&ROW())<>"", INDIRECT("'"&F$6&"'!P"&ROW()), ""),"")),"")وفي خلية F6 ====> أسماء أوراق العمل
يمكنك إتباع الخطوات التالية لجلب أسماء أوراق العمل للقائمة المنسدلة بشكل ديناميكي
=OFFSET(F!$B$6, 0, 0, COUNTIF(F!$B$6:$B$10000, "<>"), 1)=NameWS-
3
-
-
-
لقد تم تعديل الكود في المشاركة السابقة لتتناسب مع طلبك يمكنك إعادة تحميل الملف من المرفقات
مثال للنتائج المتوقعة :
-
2
-
-
أخي @جلال محمد الكود فعلا يتحقق من ثلاثة شروط
التاريخ + الكود + رقم السشن
بمعنى عند تحديد تاريخ معين يتم البحث عن مطابقة الكود في الورقتين وجلب بيانات عمود السشن المقابل لنفس الكود عند التحقق من وجوده الى الاعمدة الخاصة بكل سشن وفي نفس نطاق التاريخ المحدد أعتقد أن هذا ما جاء في طلبك سابقا
4 ساعات مضت, جلال محمد said:عند دخول معلم الحصة الاولي عند الترحيل يتم ترحيل عمود الحصة الاولي فقط ... وهكذا
ممكن توضح هذه النقطة لو سمحت
هل تقصد أن يتم جلب قيمة اول سشن لكل معلم فقط عند العثور على اول كود وتجاهل الأكواد الموالية او ماذا؟
-
وعليكم السلام ورحمة الله تعالى وبركاته
جرب هدا
Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String, f As Long, i As Long, j As Long Dim lr As Long, lastRow As Long, linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation: Exit Sub With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr: Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation: Exit Sub Set Irow = .Columns("E:P").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows) lr = IIf(Not Irow Is Nothing And Irow.row >= 5, Irow.row, 5) .Range(.Cells(5, f), .Cells(lr, f + 4)).ClearContents End With lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).row xCode = False: c = False For i = 12 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i Select Case True Case c MsgBox "تم ترحيل البيانات بنجاح", vbInformation Case Not xCode MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation Case Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End Select End Sub
-
1
-
1
-
-
اسف لم أنتبه قمت بإظافة الرد على الموضوع بالخطأ المفروض الإستفسار كان لموضوع أخر على المنتدى
-
وعليكم السلام ورحمة الله تعالى وبركاته
الخلية C2 عدد المعدات :
=COUNTIFS(بينات!$D$3:$D$500, $A$2, بينات!$AS$3:$AS$500, $B$2)الخلية D2 عدد الساعات :
=SUMIFS(بينات!$AN$3:$AN$500, بينات!$D$3:$D$500, $A$2, بينات!$AS$3:$AS$500, $B$2)التنسيق الشرطي إذا كانت الساعات أقل من 500
حدد الخلية D2 ثم ===== > Conditional Formatting ==> New Rule ==> Use a formula to determine which cells to format
واكتب الصيغة التالية:=D2<500
-
2
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
لاحظت أن الكود الخاص بك يسبب خطأ أثناء التنفيذ لأنه يحاول نسخ كامل النطاق المستخدم UsedRange من ملف book2 إلىbook1
بشكل مباشر وهذا يشمل الأزرار والأشكال وأي عناصر رسومية أخرى في الورقة مما يؤدي إلى توقف الكود أو ظهور أخطاء وبطء في الأداء بسبب كثرة العناصر المنسوخة
لذلك أنصحك باستخدام الكود التالي الذي يعتمد على نسخ الصيغ والتنسيقات فقط عبر PasteSpecial مما يمنع نسخ العناصر غير المرغوب فيها ويضمن عمل الكود بسلاسة وبدون مشاكل
Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "إدخال بيانات أساسية" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If Set OnRng = WSdata.UsedRange WSdest.Cells.UnMerge WSdest.Cells.ClearContents OnRng.Copy With WSdest.Range("A1") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("A1"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub-
2
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
جرب هل هدا ما تقصده
Option Explicit Sub GetData() On Error GoTo EndClear Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String ColArr = Split("1 2 3 4"): SetApp False Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb" If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit Set WS = Workbooks.Open(xPath) Set CrWS = WS.Sheets("Sheet1") If IsEmpty(dest.Cells(1, 1)) Then For i = 0 To UBound(ColArr) dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value Next i End If début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1 If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 For i = 0 To UBound(ColArr) dest.Cells(tbl2, i + 1).Resize(tmp).Value = _ CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value Next i Application.Goto dest.Range("A1"), True CleanExit: If Not WS Is Nothing Then WS.Close False SetApp True If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub EndClear: Resume CleanExit End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub-
2
-
1
-
-
وعليكم السلام ورحمة الله وبركاته
استكمالا لما تفضل به الأساتذة @Foksh و @hegazee من حلول مشكورة و إثراءا للموضوع أضع بين يديك اقتراحا إضافيا ربما قد يكون مناسبا لطلبك
Private Sub Worksheet_Change(ByVal Target As Range) Const ColF As Long = 5, Irow As Long = 2, Max As Long = 5 Dim rng As Range, i As Long, ky() As String, Cnt$, tmp$, msg$, txt$ If Target.Column = ColF Then On Error GoTo Cleanup SetApp False For Each rng In Target txt = Trim(CStr(rng.Value)): msg = "" If txt = "" Then GoTo NextCell If InStr(txt, "/") > 0 Then msg = "(/) " & _ "خطأ: يرجى استخدام الشرطة العادية (-) بدلا من الشرطة المائلة" If msg = "" And InStr(txt, "-") = 0 Then msg = "خطأ: التنسيق غير صحيح" If msg = "" Then ky = Split(txt, "-") If UBound(ky) <> 1 Then msg = "خطأ: يجب أن يكون التنسيق بالشكل (رقم-رموز)" Else Cnt = ky(0): tmp = ky(1) If msg = "" And (Not IsNumeric(Cnt) Or Len(Cnt) < 1 Or Len(Cnt) > Irow) Then _ msg = "خطأ: الجزء الأول يجب أن يكون رقمًا مكونا من رقم أو رقمين فقط" If msg = "" And Len(tmp) > Max Then msg = "خطأ: الحد الأقصى للرموز بعد الشرطة هو 5 رموز" If msg = "" And Left(tmp, 1) = "0" Then msg = "خطأ: لا يسمح ببدء الجزء الثاني بصفر" For i = 1 To Len(tmp) - 1 If msg = "" And Mid(tmp, i, 1) Like "[A-Za-z]" And Mid(tmp, i + 1, 1) = "0" Then msg = "خطأ: لا يسمح بوجود صفر بعد الحرف الإنجليزي": Exit For End If Next i End If End If If msg <> "" Then MsgBox msg, vbCritical, "خطأ في إدخال رقم الحالة": rng.Value = "" NextCell: Next rng End If Cleanup: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub-
3
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
بعد إدن أستادنا الفاضل @Foksh
جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك
Private Sub UserForm_Initialize() ComboBox1.Clear: Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets: ComboBox1.AddItem sh.Name: Next ListBox1.ColumnCount = 3: ListBox1.ColumnWidths = "70;70;200" End Sub Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Dim ShName As String, Addr As String ShName = ListBox1.List(ListBox1.ListIndex, 0) Addr = ListBox1.List(ListBox1.ListIndex, 1) Sheets(ShName).Activate Sheets(ShName).Range("A4:F" & Sheets(ShName).Rows.Count).Interior.ColorIndex = xlNone With Sheets(ShName).Range("A" & Range(Addr).Row & ":F" & Range(Addr).Row) .Interior.Color = vbCyan: .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.List(ListBox1.ListIndex, 2) End Sub Private Sub TextBox1_Change() On Error GoTo Cleanup SetApp False Dim ws As Worksheet, Sh_Name As String, ky As String, LastRow As Long, LastCol As Long Dim OnRng As Variant, i As Long, j As Long, xCount As Long, CellAddress As String Sh_Name = ComboBox1.Value ky = Trim(TextBox1.Text) If Sh_Name = "" Or ky = "" Then ListBox1.Clear Label5.Caption = "عدد النتائج: 0" If Sh_Name <> "" Then Sheets(Sh_Name).Range("A4:F" & _ Sheets(Sh_Name).Rows.Count).Interior.ColorIndex = xlNone Me.TextBox2 = "" GoTo Cleanup End If Set ws = Sheets(Sh_Name) With ws LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column End With ListBox1.Clear ws.Range("A4:F" & ws.Rows.Count).Interior.ColorIndex = xlNone xCount = 0 OnRng = ws.Range(ws.Cells(4, 1), ws.Cells(LastRow, LastCol)).Value For i = 1 To UBound(OnRng, 1) For j = 1 To UBound(OnRng, 2) If InStr(1, OnRng(i, j), ky, vbTextCompare) > 0 Then xCount = xCount + 1 CellAddress = ws.Cells(i + 3, j).Address(False, False) ListBox1.AddItem Sh_Name ListBox1.List(ListBox1.ListCount - 1, 1) = CellAddress ListBox1.List(ListBox1.ListCount - 1, 2) = OnRng(i, j) ws.Range("A" & (i + 3) & ":F" & (i + 3)).Interior.Color = vbCyan Exit For End If Next j Next i Label5.Caption = "عدد النتائج: " & xCount Cleanup: SetApp True End Sub Private Sub UserForm_Terminate() Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = "": ListBox1.Clear End Sub Private Sub ComboBox1_Change() On Error Resume Next If ComboBox1.ListIndex = -1 Then Exit Sub TextBox1 = "": ListBox1.Clear Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next Sheets(ComboBox1.Value).Activate End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Subملاحظة :تم الاستغناء عن الكود Search_In_Sh() فأنت الآن لست بحاجة إليه
-
4
-
-
7 ساعات مضت, Hesham.Abusna said:
لاحظت ان الكود لايعمل جيدا على الملفات بصيغة الماكرو او الملفات التي بعا معادلات كثيرة و اكواد
لكن في الملفات ضغيرة و بسيطة الحجم المعادلات و الاكواد .. تجده يعمل بكفاءة
أخي @Hesham.Abusna
نرجو منك التكرم بإرفاق نسخة من الملف الذي واجهت فيه المشكلة هدا سيساعدنا ذلك كثيرا على فحص هيكل الملف و المعادلات المستخدمة ولربما حجم البيانات ومن ثم تقديم الحل الأمثل بإذن الله
كما يجب الإنتباه أنه في بعض الحالات قد يتسبب حجم المعادلات الكبير أو وجود أكواد معقدة أو حتى أوراق فارغة أو مخفية في اختلاف سلوك الكود لذلك فالمعاينة المباشرة ضرورية لتقديم دعم دقيق ومناسب و تشخيص المشكلة بدقة والوقوف على السبب الفعلي
على العموم جرب الكود التالي على ملفك الأصلي ووافينا بالنتيجة
Option Explicit Sub Sauvegarde_WB() Dim dossier$, chemin$, sFichier$, sPath$, sNom$ Dim WS As Worksheet, newWB As Workbook, newWs As Worksheet Dim n As Integer, data As Variant, OnRng As Range, _ shp As Shape, col As Long, rw As Long On Error GoTo EndClear SetApp False Set newWB = Workbooks.Add(xlWBATWorksheet) newWB.Sheets(1).Name = "Temp" n = 1 For Each WS In ThisWorkbook.Worksheets Set newWs = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count)) sNom = Left(WS.Name, 31) Do While f(sNom, newWB) sNom = Left(WS.Name, 28) & "_" & n: n = n + 1 Loop newWs.Name = sNom Set OnRng = WS.UsedRange If OnRng.Cells.Count > 1 Then data = OnRng.Value newWs.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data OnRng.Copy newWs.Range("A1").PasteSpecial xlPasteFormats Application.CutCopyMode = False For col = 1 To OnRng.Columns.Count newWs.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth Next col For rw = 1 To OnRng.Rows.Count newWs.Rows(rw).RowHeight = WS.Rows(rw).RowHeight Next rw Application.Goto newWs.Range("A1"), True End If On Error Resume Next For Each shp In newWs.Shapes If shp.Type = msoFormControl Or shp.Type = msoOLEControlObject Then shp.Delete Next shp On Error GoTo EndClear Next WS newWB.Sheets("Temp").Delete dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sFichier = sPath & "_" & Format(Now, "dd-mm-yyyy_hh-nn-ss") & ".xlsx" chemin = dossier & "\" & sFichier newWB.Sheets(1).Activate newWB.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook newWB.Close False MsgBox "تم نسخ الملفات بنجاح", vbInformation SetApp True Exit Sub EndClear: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub Private Function f(sheetName As String, wb As Workbook) As Boolean Dim sht As Worksheet For Each sht In wb.Sheets If sht.Name = sheetName Then f = True: Exit Function Next sht f = False End Functionإليك المرفق مرة أخرى بعد إظافة بعض المعادلات الجديدة للتجربة
-
2
-
1
-
-
لنجرب هذا مع إظافة الترتيب الأبجدي لعناصر الـكومبوبوكس عند النقر المزدوج يتم ترتيب القائمة تلقائيا قبل العرض
Option Explicit Dim WS As Worksheet Dim OnRng As Variant Dim ColArr As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("داتا") Dim f As Worksheet: Set f = Sheets("Sheet1") Dim lastRow As Long, cnt As Boolean, i As Long cnt = False lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If Trim(f.Cells(i, "A").Value) <> "" Then cnt = True Exit For End If Next i 'A' إظهار القوائم لغاية أخر صف يتضمن تاريخ على عمود' If cnt Then If Target.Count = 1 And Not Intersect(Target, Range("C2:O" & lastRow)) Is Nothing Then ' OR ' C2:O100 تحديد اخر صف لإظهار القوائم يدويا بما يناسبك ' If Target.Count = 1 And Not Intersect(Target, Range("C2:O100")) Is Nothing Then ColArr = Target.Column If xColumn(ColArr) Then On Error Resume Next OnRng = WS.Range(WS.Cells(2, ColArr), _ WS.Cells(WS.Rows.Count, ColArr).End(xlUp)).Value On Error GoTo 0 If Not IsEmpty(OnRng) Then If Not IsArray(OnRng) Then ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = WS.Cells(2, ColArr).Value End If Me.ComboBox1.List = Application.Transpose(OnRng) Else Me.ComboBox1.List = Array() End If With Me.ComboBox1 .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() Dim d1 As Object Dim tmp As String Dim i As Long Set d1 = CreateObject("Scripting.Dictionary") If Me.ComboBox1.Value = "" Then Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.DropDown Else tmp = UCase(Me.ComboBox1.Value) & "*" For i = 1 To UBound(OnRng, 1) If UCase(Trim(OnRng(i, 1))) Like tmp Then d1(Trim(OnRng(i, 1))) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown Else Me.ComboBox1.List = Array(Me.ComboBox1.Value) Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_Click() Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Function xColumn(colNum As Long) As Boolean Select Case colNum Case 3, 4, 5, 9, 10, 11, 15 xColumn = True Case Else xColumn = False End Select End Function Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) On Error Resume Next Dim listArr() As String, i As Long If Not IsEmpty(OnRng) Then ReDim listArr(1 To UBound(OnRng, 1)) For i = 1 To UBound(OnRng, 1) listArr(i) = OnRng(i, 1) Next i Call filtre(listArr) Me.ComboBox1.List = listArr End If Me.ComboBox1.Value = "" Me.ComboBox1.Activate Me.ComboBox1.DropDown On Error GoTo 0 End Sub Private Sub filtre(arr() As String) Dim i As Long, j As Long, temp As String, n As Long n = UBound(arr) For i = 1 To n - 1 For j = i + 1 To n If StrComp(arr(i), arr(j), vbTextCompare) > 0 Then temp = arr(i): arr(i) = arr(j): arr(j) = temp End If Next j Next i End Sub-
2
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
أخي @sabah19672025 أعتقد أن طلبك غير واضح نوعا ما
يمكن تنفيذ ذلك بعدة طرق حسب طريقة عملك واحتياجك ونحتاج فقط لتحديد الطريقة التي تفضل استخدامها:
هل اختيار الملفات يدويا أي يتم عرض نافذة لتحديد ملفات PDF التي تريد نقلها (واحد أو أكثر) وسيقوم الكود تلقائيا بـإنشاء مجلد بنفس اسم كل ملف و نقل الملف إلى داخل هذا المجلد
أم البحث داخل مجلد معين بحيث يتم تحديد مجلد يحتوي على الملفات المعنية و البحث داخله تلقائيا عن كل ملفات PDF مع إنشاء مجلد بنفس اسم كل ملف و نقل كل ملف إلى المجلد المناسب دفعة واحدة
عموما إليك عدة إحتمالات يمكن إختيار ما يناسبك منها
Sub test_MovePDF() Dim dl As FileDialog, selectedItems As Variant, fso As Object, i As Integer Dim xPath As String, xName As String, xFolder As String, newFolder As String Set dl = Application.FileDialog(msoFileDialogFilePicker) With dl .AllowMultiSelect = True .Title = "اختر ملفات PDF" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) xName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) newFolder = xFolder & "\" & Left(xName, Len(xName) - 4) If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & "\" & xName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '=================================== Sub Move_Selected_PDFs_To_Folders() Dim fso As Object, fd As FileDialog Dim i As Long Dim xPath As String, fileName As String, xFolder As String, newFolder As String Dim baseName As String Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملفات PDF المتفرقة" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" .AllowMultiSelect = True If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) fileName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) baseName = fso.GetBaseName(fileName) newFolder = xFolder & Application.PathSeparator & baseName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & fileName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '========================================= Sub test_Move_allPDF() Dim fso As Object, file As Object, newFolder As String Dim xFolder As String, xName As String, xPath As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد الذي يحتوي على ملفات PDF" If .Show <> -1 Then Exit Sub xFolder = .selectedItems(1) End With Set fso = CreateObject("Scripting.FileSystemObject") For Each file In fso.GetFolder(xFolder).Files If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then xName = fso.Getn(file.Name) xPath = file.Path newFolder = xFolder & Application.PathSeparator & xName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & file.Name End If Next file MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub-
2
-
-
أخي الكريم @زياد الحسناوي تحية طيبة
هناك إستفسار بسيط فقط للتوضيح:
هل المشكلة التي واجهتها تظهر فقط عند نقل المعادلة إلى ملفك الأصلي؟
أم أن الخطأ موجود أيضا في الملفات التي تم تحميلها من المنتدى؟
الهدف من هذا السؤال هو التحقق ما إذا كانت المشكلة ناتجة عن طريقة النقل أو التعديل على الملف الأصليقبل الخوض في آخر توضيح لي ضمن هذا الموضوع أود أن أعتذر عن الخطأ غير المقصود في نسخ المعادلة الأخيرة داخل الرد في المداخلة السابقة رغم أنها كانت مكتوبة بشكل صحيح تماما داخل الملف المرفق
في 20/6/2025 at 18:05, محمد هشام. said:=IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A))) ), ROWS(D$2:D2)), "")
المعادلة تعمل على البحث عن الأرقام المفقودة ضمن تسلسل يبدأ من أصغر رقم MIN(A:A) إلى أكبر رقم MAX(A:A) وترجع فقط الأرقام غير الموجودة فعليا في العمود A
المعادلة الصحيحة
=IFERROR(SMALL( IF(ISNA(MATCH(ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A))), A:A, 0)), ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A))) ), ROWS(C$1:C1)), "")أو
=IFERROR(SMALL(IF(COUNTIF(A:A,ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A)))) =0,ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A)))),ROWS(D$1:D1)),"")أو بطريقة متقدمة نوعا ما
=FILTER(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), ISNA(MATCH(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), A:A, 0)))أما بخصوص الحلول المقترحة تم تزويدك بعدة حلول مختلفة لتختار ما يناسب أسلوب عملك في الملف لأنك لم تحدد في سؤالك
هل ترغب في عرض القيم المفقودة بشكل متسلسل دون فراغات؟
أم ترغب في عرضها بنفس مواقع الصفوف الأصلية (مع فراغات)؟
لذلك تم عرض كلا الإحتمالين ومن بينها المعادلة التي أشرت إليها تعرض القيم المفقودة مع وجود فراغات
=IF(COUNTIF(A:A, ROW())=0, ROW(), "")مع تزويدك أيضا بمعادلة تعرض القيم المفقودة بشكل متسلسل دون فراغات
=IFERROR( SMALL( IF(COUNTIF(A:A, ROW(INDIRECT("1:1900"))) = 0, ROW(INDIRECT("1:1900")) ), ROWS(J$1:J1) ), "")إذا كنت تريد إستخراج القيم المفقودة بناء على الحد الأدنى والحد الأعلى في العمود A بدون تحديد 1900 يدويا فقد تم التنبيه لدالك سابقا يمكنك تعديل
( 1:1900 ) حسب النطاق الذي تعمل عليه مثلا "1:"&MAX(A:A) ليتغير تلقائيا حسب البيانات
=IFERROR( SMALL( IF(COUNTIF(A:A, ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A)))) = 0, ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A))) ), ROWS(J$1:J1) ), "")وبهذا ستكون بين يديك عدة اختيارات يمكنك تحديد ما يناسبك منها وفق الإصدار المستخدم لديك وشكل النتائج المتوقعة
وهذه صورة توضح بياناتك بعد تصحيح المعادلات في الملف وتؤكد أنها تعمل كما هو متوقع
ملاحظة أخيرة:
يرجى التأكد من نسخ المعادلات كما هي دون تعديل أو حذف جزء منها مع مراعات تعديل عناوين الخلايا في حالة نسخها إلا عمود مختلف لأن أي خطأ بسيط في الصيغة قد يؤدي إلى عدم عملها بالشكل الصحيح وهذا ما تم ملاحظته في الملف الأخير المرفق من طرفكوأخيرا إدا كنت تستخدم إصدار حديث من الأوفيس فأفضل حل بالنسبة لك هو
=FILTER(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), ISNA(MATCH(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), A:A, 0)))بالتوفيق..........
-
1
-
-
تفضل أخي ضع الكود التالي في حدث ورقة Sheet1
Option Explicit Dim OnRng As Variant Dim Cnt As Long Dim CrWS As Worksheet Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim dict As Object, lastRow As Long, i As Long, val As String, key As Variant, a As Variant On Error GoTo SupApp If Target.CountLarge > 1 Or Target.Row < 2 Or _ Target.Row > 100 Then ' '<==== هنا قم بتعديل اخر صف لاظهار القوائم بما يناسبك ComboBox1.Visible = False Exit Sub End If If ComboBox1 Is Nothing Then Exit Sub Set CrWS = ThisWorkbook.Sheets("داتا") If CrWS Is Nothing Then Exit Sub Cnt = Target.Column Select Case Cnt Case 3, 4, 5, 9, 10, 11, 15 lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then ComboBox1.Visible = False Exit Sub End If a = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value Set dict = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) val = Trim(CStr(a(i, 1))) If val <> "" Then If Not dict.Exists(val) Then dict.Add val, Nothing End If End If Next i If dict.Count > 0 Then ReDim OnRng(1 To dict.Count, 1 To 1) i = 1 For Each key In dict.Keys OnRng(i, 1) = key i = i + 1 Next key Else ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = "" End If With ComboBox1 .List = Application.Transpose(OnRng) .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Case Else ComboBox1.Visible = False End Select Exit Sub SupApp: ComboBox1.Visible = False End Sub Private Sub ComboBox1_Change() On Error Resume Next If Me.ComboBox1.Value <> "" Then Dim d1 As Object, i As Long Set d1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(OnRng, 1) If InStr(1, UCase(OnRng(i, 1)), UCase(Me.ComboBox1.Value), vbTextCompare) > 0 Then d1(OnRng(i, 1)) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ActiveCell.Offset(1).Select ComboBox1.Visible = False KeyCode = 0 ElseIf KeyCode = vbKeyEscape Then ComboBox1.Visible = False KeyCode = 0 End If End Sub Private Sub ComboBox1_Click() On Error Resume Next If CrWS Is Nothing Then Exit Sub Dim lastRow As Long, xRng As Variant lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then Exit Sub xRng = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value If Not IsArray(xRng) Then ReDim tmp(1 To 1, 1 To 1) tmp(1, 1) = xRng xRng = tmp End If Me.ComboBox1.List = Application.Transpose(xRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub-
1
-
-
منذ ساعه, زياد الحسناوي said:
وين كانت المشكلة
ببساطة أخي @زياد الحسناوي بعد إضافة الأرقام الجديدة لم تقم بسحب المعادلات للأسفل كما تمت الإشارة إليه في المشاركة السابقة
وذلك لأنني قمت بوضع المعادلة على الملف المرفق بقدر البيانات الموجودة سابقا فقط
هناك كدالك نقطة مهمة يجب الإنتباه إليها في المعادلة المقترحة
=IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(D$2:D2)), "")
وظيفتها إظهار الأرقام المفقودة من تسلسل يبدأ من 1 حتى أكبر رقم موجود في العمود A وتعرض النتيجة في العمود D أو B حسب وضعها كما جاء في طلبك لكن هذه الصيغة تفترض أن الأرقام تبدأ من 1 وتتزايد بواحدمثال
عندما تكون الأرقام بهذا الشكل مثلا
فالصيغة أعلاه لن تعمل كما يجب لأنها تبدأ بالبحث من الرقم 1 بينما الأرقام الفعلية تبدأ من 15 لحل هذا الإشكال
نقترح استخدام الصيغة التالية التي تعتمد على أصغر وأكبر رقم موجودين فعليا في العمود A
=IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A))) ), ROWS(D$2:D2)), "")
المعادلة تبحث عن جميع الأرقام بين MIN و MAX وتستبعد الأرقام الموجودة فعليا في العمود A أي ترجع فقط الأرقام المفقودة في تسلسل منتظم وتعرض النتائج بشكل ديناميكي في العمود D بدءا من D2-
4
-
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
الطريقة 1 : ضع المعادلة مثلا في B2 واسحب للأسفل:
=IF(COUNTIF(A:A, ROW())=0, ROW(), "")الطريقة 2 : ضع المعادلة التالية مع استبدال الرقم 100 حسب الحد الأقصى في بياناتك ثم اسحب للأسفل:
=IFERROR(SMALL(IF(COUNTIF(A:A,ROW(INDIRECT("1:100")))=0,ROW(INDIRECT("1:100"))),ROWS(B$1:B1)),"")أو بشكل ديناميكي
=IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(B$2:B2)), "")ادا كنت تستخدم نسخة حديثة من الأوفيس
=LET( maxVal, MAX(A:A),fullSet, SEQUENCE(maxVal),missing, FILTER(fullSet, ISNA(MATCH(fullSet, A:A, 0))), IF(ROWS(B$2:B2)<=ROWS(missing), INDEX(missing, ROWS(B$2:B2)), ""))او بإستخدام الأكواد : يمكنك تعديل Max لتحديد الحد الأقصى الذي تبحث فيه عن الأرقام
Option Explicit Sub RechercherNum() Dim lastRow As Long, i As Long, Max As Long Dim dict As Object, tmp As Long, col As String, a As Variant Dim WS As Worksheet: Set WS = Sheets("ورقة1") Set dict = CreateObject("Scripting.Dictionary") col = "G" ' عمود وضع القيم المفقودة Max = 100 ' الحد الأقصى المتوقع With Application .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False WS.Range(col & "2:" & col & WS.Rows.Count).ClearContents lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow a = WS.Cells(i, 1).Value If IsNumeric(a) Then dict(CLng(a)) = True Next i tmp = 2 For i = 1 To Max If Not dict.exists(i) Then WS.Cells(tmp, col).Value = i tmp = tmp + 1 End If Next i .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True End With End Sub-
1
-
-
-
5
-
-
وعليكم السلام ورحمة الله تعالى وبركاته
Sub Sheets_Arrays3() Dim lr&, LR2&, WSData As Worksheet Dim Dest As Worksheet: Set Dest = Sheets("class_room") LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row If LR2 >= 2 Then Dest.Range("B2:S" & LR2).ClearContents Application.ScreenUpdating = False For Each WSData In Sheets(Array("كي جي1", "كي جي2", _ "الصف الأول", "الصف الثاني", "الصف الثالث", "الصف الرابع", "الصف الخامس", "الصف السادس")) lr = WSData.Cells(WSData.Rows.Count, "B").End(xlUp).Row If lr >= 3 Then LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row + 1 Dest.Range("B" & LR2 & ":S" & (LR2 + lr - 3)).Value = WSData.Range("B3:S" & lr).Value End If Next WSData Application.ScreenUpdating = True MsgBox "تم ترحيل الفرق بنجاح", vbInformation End Sub-
3
-
إدخال قيمة بشرط
في منتدى الاكسيل Excel
قام بنشر
Private Sub UserForm_Initialize() Me.TextBox3.Value = Format(Date, "dd/mm/yyyy") Me.TextBox3.Locked = True Me.TextBox2.Value = "" End SubCastrole v3.xlsm