اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

الخبراء
  • Posts

    738
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    5

كل منشورات العضو عبدالفتاح في بي اكسيل

  1. جرب هذا الكود بمجرد كتابة الرقم سيتم الفرز تلقائيا 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
  2. جرب هذا الماكرو عليك بوضع ملفاتك في مجلد محدد يقوم الماكرو بفتح المستعرض حدد المجلد الذي به الملفات ثم قم يتحديد كامل الملفات وسيقوم بدمجها في ملفك مع مراعاة اسم الورقة بالانجليزي في ملف التجميع 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
  3. لماذا لا تحدد العمود وتقوم بتغيير خيارات من اعلى الشريط من عام الى تاريخ كما في الصورة GENERAL
  4. لا تنتظر المساعدة دون وضع شرح تفصيلي لا احد يعمل على التخمين
  5. لماذ تكرر المواضيع ولماذا لاترد على اجابة الاخرين اذا كان هذا ما تريده ام لا https://www.officena.net/ib/topic/109433-nototxt-دالة-التفقيط-بالدينار-الكويتي/
  6. لا اعتقد يمكن المساعدة افصل موضوعك الى عدة اجزاء طلبات كثيرة لا اعتقد ان احد سيدخل في هكذا مواضيع ثم ان بياناتك معظمها بها خلايا مدمجة ولا احد يمكن احد ان يقوم بتنسيقها
  7. هل تقصد تسمية صورة الموظف الموجودة في المجلد بناء على اسمه في الحقل ثم نوعية الاسماء الفعلية للملفات هل ارقام ارقام واحرف هل الملفات فقط في مجلد واحد ام يوجد ملفات فرعية ا م ماذا؟ موضوعك ينقصه التفصيل لذلك لن تجد احد يدخل في هكذا مواضيع لا تحتوي على تفاصيل
  8. يرحل ويحدف انزل لاخر الورقة وسترى البيانات لا ادري يوجد مشكلة في التنسيق لم يعجبني تنسيقك في الاعلى يوجد تنسيقات جدول ثم فراغات ثم في الاسفل 😕
  9. على حد علمي لا يمكن ذلك وهذا هو عيب الاكسيل لا يتحمل هذا الشيء عن تجربة شخصية ونصيحتي لك تقوم بتقسمه الى عدة ملفات وربطها ببعضها حتى لا يتلف خصوصا اذاكانت البيانات مهمة وقد لا تكون المشكلة في الملف قد يكون في الجهاز لطالما حدثت معي هكذا امور واتضح من الجهاز يمكنك اكتشاف ذلك من تشغيل الملف على اكثر من جهاز حتى تعرف ذلك
  10. جرب هذا الماكرو 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
  11. غير خاصية ShowDropButtonWhen هذه من خصائص الكموبوبوكس الى القيمة 1 مع ملاحظة يجب ان يكون زر الكومبوبوكس من نوع active x
  12. جرب هذا الشيء لعله يفيدك 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
  13. اذا كنت تريد تغيير اليوم والشهر فقط يمكن وضعه في الحدث 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
  14. جرب هذا الماكرو قم بانشاء صفحة خاصة لطباعة الاوراق وقم بوضع اسماء الاوراق التي تود طباعتها ابتداء من الصف الثاني في العمود 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
  15. الكود شغال معي بما انك لا تريد ارفاق ملف فلا تنتظر المساعدة ملاحظة اخيرة جرب وضعه في حدث afterupdate عليك الانتظار من الاساتذة الاخرين لتجد حل لمشكلتك بدون ملف
  16. وهل كل ملف يحتوي على ورقة واحدة اوعدة اوراق اذا كان ورقة واحدة موضوع اما اذاكانت عدة اوراق وكل ورقة لوحدها هذا موضوع مختلف تماما معلوماتك شحيحة للغاية اقترح عليك اعادة صياغة سؤالك من جديد وكيف تريد البيانات لان لا احد يعلم ما في عقلك
  17. جرب هذا وغير رقم التيكست بوكس لظهور التاريخ اكتب اول رقم وسيكمل باقي التاريخ 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
  18. يجب ان تشرح بتفصيل وافي الخلية التي تريدها كيف يتم حسابها اعطي مثال عن القيم كيف كانت وكيف تصبح بناء على رغبتك حتى تجد تفاعل من الاعضاء
  19. جرب هذا التعديل بالمصفوفة مع مراعاة تسمية الورقة بالانجليزي حتى لا يحدث مشاكل في الكود يتم اظهار البيانات بعد كتابة 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
  20. لا ادري اذا كان هذا ما تريده جرب هذا الملف جلب البيانات على اساس راس الجدول1.xlsm
×
×
  • اضف...

Important Information