عبدالفتاح في بي اكسيل

جرب هذا الكود بمجرد كتابة الرقم سيتم الفرز تلقائيا Private Sub Worksheet_Change(ByVal Target As Range) Dim SR As Long If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub With Worksheets("Sheet1") SR = .Cells(.Rows.Count, "F").End(xlUp).Row .Range("B4:F" & SR).Sort Key1:=.Range("F4"), Order1:=xlDescending, Header:=xlYes End With End Sub SORT.xlsm

جرب هذا الماكرو عليك بوضع ملفاتك في مجلد محدد يقوم الماكرو بفتح المستعرض حدد المجلد الذي به الملفات ثم قم يتحديد كامل الملفات وسيقوم بدمجها في ملفك مع مراعاة اسم الورقة بالانجليزي في ملف التجميع Worksheet Sub Consolidation() Dim CurrentBook As Workbook Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("Worksheet") Dim IndvFiles As FileDialog Dim FileIdx As Long Dim i As Integer, x As Integer With WS If Len(.Range("a2")) Then Intersect(.UsedRange, .UsedRange.Offset(0)).Clear 'removes old data End If End With Set IndvFiles = Application.FileDialog(msoFileDialogOpen) With IndvFiles .AllowMultiSelect = True .Title = "Multi-select target data files:" .ButtonName = "" .Filters.Clear .Filters.Add ".xlsx files", "*.xlsx" .Show End With Application.DisplayAlerts = False Application.ScreenUpdating = False For FileIdx = 1 To IndvFiles.SelectedItems.Count Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx)) For Each Sheet In CurrentBook.Sheets Dim LRow1 As Long LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row + 2 Dim LRow2 As Long LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row Dim ImportRange As Range Set ImportRange = CurrentBook.ActiveSheet.Range("A2:F" & LRow2) ImportRange.Copy WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next CurrentBook.Close False Next FileIdx Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

لا اتخيل ان جهاز الكمبيوتر يحتمل فتح اكثر من 100 ملف !!!!

لماذا لا تحدد العمود وتقوم بتغيير خيارات من اعلى الشريط من عام الى تاريخ كما في الصورة GENERAL

لا تنتظر المساعدة دون وضع شرح تفصيلي لا احد يعمل على التخمين

لماذ تكرر المواضيع ولماذا لاترد على اجابة الاخرين اذا كان هذا ما تريده ام لا https://www.officena.net/ib/topic/109433-nototxt-دالة-التفقيط-بالدينار-الكويتي/

لا اعتقد يمكن المساعدة افصل موضوعك الى عدة اجزاء طلبات كثيرة لا اعتقد ان احد سيدخل في هكذا مواضيع ثم ان بياناتك معظمها بها خلايا مدمجة ولا احد يمكن احد ان يقوم بتنسيقها

هل تقصد تسمية صورة الموظف الموجودة في المجلد بناء على اسمه في الحقل ثم نوعية الاسماء الفعلية للملفات هل ارقام ارقام واحرف هل الملفات فقط في مجلد واحد ام يوجد ملفات فرعية ا م ماذا؟ موضوعك ينقصه التفصيل لذلك لن تجد احد يدخل في هكذا مواضيع لا تحتوي على تفاصيل

يرحل ويحدف انزل لاخر الورقة وسترى البيانات لا ادري يوجد مشكلة في التنسيق لم يعجبني تنسيقك في الاعلى يوجد تنسيقات جدول ثم فراغات ثم في الاسفل 😕

على حد علمي لا يمكن ذلك وهذا هو عيب الاكسيل لا يتحمل هذا الشيء عن تجربة شخصية ونصيحتي لك تقوم بتقسمه الى عدة ملفات وربطها ببعضها حتى لا يتلف خصوصا اذاكانت البيانات مهمة وقد لا تكون المشكلة في الملف قد يكون في الجهاز لطالما حدثت معي هكذا امور واتضح من الجهاز يمكنك اكتشاف ذلك من تشغيل الملف على اكثر من جهاز حتى تعرف ذلك

جرب هذا الماكرو Sub MOVEROWS() lastrow = Worksheets("data").UsedRange.Rows.Count lastrow2 = Worksheets("save").UsedRange.Rows.Count If lastrow2 = 1 Then lastrow2 = 0 Else End If Do While Application.WorksheetFunction.CountIf(Range("Q:Q"), "منتهي") > 0 Set Check = Range("Q1:Q" & lastrow) For Each Cell In Check If Cell = "منتهي" Then Cell.EntireRow.Copy Destination:=Worksheets("SAVE").Range("A" & lastrow2 + 1) Cell.EntireRow.Delete lastrow2 = lastrow2 + 1 Else: End If Next Loop End Sub

غير خاصية ShowDropButtonWhen هذه من خصائص الكموبوبوكس الى القيمة 1 مع ملاحظة يجب ان يكون زر الكومبوبوكس من نوع active x

جرب هذا الشيء لعله يفيدك Private Sub TextBox1_AfterUpdate() If Application.WorksheetFunction.CountIf(Worksheets("DATA").Range("A2:A10000"), TextBox1.Text) > 0 Then MsgBox (" عفوا رقم السجيل مكرر"), vbInformation Cancel = True End If TextBox1.Value = "" End Sub

اذا كنت تريد تغيير اليوم والشهر فقط يمكن وضعه في الحدث CHANGE Private Sub TextBox1_CHANGE() If IsDate(TextBox1.Value) Then TextBox1.Value = Format(TextBox1.Value, "YYYY/MM/DD") End Sub اما اذا اردت تغييره كامل عليك بجعل تيكس بوكس بعدها مباشرة لانه يعتمد على ادخال التاريخ ثم انتر لينتقل الى تيكست بوكس الذي يليه وستلاحظ تغير صيغة التاريخ Private Sub TextBox1_AfterUpdate() If IsDate(TextBox1.Value) Then TextBox1.Value = Format(TextBox1.Value, "YYYY/MM/DD") End Sub

تم التعديل كتابة التاريخ بتنسيق معين.xlsm

جرب هذا الماكرو قم بانشاء صفحة خاصة لطباعة الاوراق وقم بوضع اسماء الاوراق التي تود طباعتها ابتداء من الصف الثاني في العمود A Sub PrintAllSheets() Dim c As Range Dim s As String On Error GoTo errHandle For Each c In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) Worksheets(c.Value).PrintOut Next c Exit Sub errHandle: s = "Error while trying to print sheet '" & c.Value & "'" & vbNewLine & Err.Description MsgBox s, vbCritical, "Error No. " & Err.Number End Sub

الكود شغال معي بما انك لا تريد ارفاق ملف فلا تنتظر المساعدة ملاحظة اخيرة جرب وضعه في حدث afterupdate عليك الانتظار من الاساتذة الاخرين لتجد حل لمشكلتك بدون ملف

وهل كل ملف يحتوي على ورقة واحدة اوعدة اوراق اذا كان ورقة واحدة موضوع اما اذاكانت عدة اوراق وكل ورقة لوحدها هذا موضوع مختلف تماما معلوماتك شحيحة للغاية اقترح عليك اعادة صياغة سؤالك من جديد وكيف تريد البيانات لان لا احد يعلم ما في عقلك

جرب هذا وغير رقم التيكست بوكس لظهور التاريخ اكتب اول رقم وسيكمل باقي التاريخ Private Sub TextBox1_Change() Dim ldate As Date ldate = DateSerial(Year(Date), Month(Date), Day(Date)) TextBox1.Value = Format(TextBox1.Value, "yyyy/mm/dd") ldate = TextBox1.Value End Sub

يجب ان تشرح بتفصيل وافي الخلية التي تريدها كيف يتم حسابها اعطي مثال عن القيم كيف كانت وكيف تصبح بناء على رغبتك حتى تجد تفاعل من الاعضاء

جرب هذا التعديل بالمصفوفة مع مراعاة تسمية الورقة بالانجليزي حتى لا يحدث مشاكل في الكود يتم اظهار البيانات بعد كتابة 3 رقم Option Base 1 Private Sub TextBox8_Change() Dim sh As Worksheet, ArchiveArray As Variant Set sh = Sheets("archives") ArchiveArray = sh.Range("A2:G" & Range("A" & Rows.Count).End(xlUp).Row).Value 'grab data into the array Dim i As Long If Len(TextBox8.Value) >= 3 Then 'if three characters entered... Me.ListBox1.Clear For i = 1 To UBound(ArchiveArray, 1) 'run through array If InStr(LCase(ArchiveArray(i, 1)), Me.TextBox8) <> 0 Then ' add to list if chars match With Me.ListBox1 .ADDITEM ArchiveArray(i, 1) .List(ListBox1.ListCount - 1, 1) = ArchiveArray(i, 2) .List(ListBox1.ListCount - 1, 2) = ArchiveArray(i, 3) .List(ListBox1.ListCount - 1, 3) = ArchiveArray(i, 4) .List(ListBox1.ListCount - 1, 4) = ArchiveArray(i, 5) .List(ListBox1.ListCount - 1, 5) = ArchiveArray(i, 6) .List(ListBox1.ListCount - 1, 6) = ArchiveArray(i, 7) End With End If 'Next x Next i End If End Sub

جرب هذا الملف count .xlsx

جرب هذه المحاولة ترقيم.xlsm

لا ادري اذا كان هذا ما تريده جرب هذا الملف جلب البيانات على اساس راس الجدول1.xlsm

جرب هذا جمع كودين.xlsm