اذهب الي المحتوي
أوفيسنا

ياسر خليل أبو البراء

المشرفين السابقين
  • Posts

    13,165
  • تاريخ الانضمام

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

  • Days Won

    411

Community Answers

  1. ياسر خليل أبو البراء's post in معرفة الأرقام الناقصة Missing Numbers في سلسلة أرقام was marked as the answer   
    إخواني الكرام في المنتدى الغالي
     
    أقدم لكم اليوم موضوع ليس بالجديد ولكنه جد مفيد (جد .. يعني جداً أوك يا جدو) ..أقصد مفيد جداً
     
    الموضوع يتمحور ويتمركز حول معرفة الأرقام المفقودة أو الأرقام الناقصة في سلسلة أرقام ..
     
    إليكم الكود الأول المؤدي للغرض (هنا يشترط ترتيب الأرقام) ، مع شرح تفصيلي لأسطر الكود لتتمكن من التعديل عليه
    Sub MissingNumber_NumbersSorted() 'يقوم الكود بإظهار الأرقام الناقصة في تسلسل معين للأرقام ويشترط ترتيب الأرقام '-------------------------------------------------------------------------     Dim SH As Worksheet     Dim LR As Long     Dim Text As String     Dim I As Long, X As Long, XX As Long      '[Sheet1] تخصيص المتغير ليساوي ورقة العمل المسماة     Set SH = Sheets("Sheet1") 'تحديد آخر صف به بيانات في العمود الأول     LR = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row 'حلقة تكرارية بداية من الصف الخامس وحتى آخر صف به بيانات في العمود الأول     For I = 5 To LR 'يساوي الفرق بين قيمة الخلية التالية وقيمة الخلية الحالية في الصف المحدد [X] المتغير         X = Val(SH.Range("A" & I + 1)) - Val(SH.Range("A" & I)) '[X] استخدام الجملة الشرطية لناتج المتغير         Select Case X 'إذا كان الفرق بين قيمة الخليتين أكبر من 1 يتم تنفيذ الحلقة التكرارية ما بين السطرين             Case Is > 1 'حلقة تكرارية لتخزين الأرقام الناقصة                 For XX = 2 To X 'يساوي المتغير نفسه مع قيمة الخلية الحالية مضاف إليها قيمة المتغير في الحلقة التكرارية ناقص واحد ثم سطر جديد[Text]المتغير المسمى 'مثال لفهم هذا السطر '------------------- 'توجد القيمة 50012 [A15] توجد القيمة 50009 وفي الخلية [A14] في الخلية 'بما أن الفرق بين الخليتين يساوي 3 إذاً سيتم تنفيذ الحلقة التكرارية 'بداية الحلقة التكرارية 2 حيث أن رقم 2 هو أول رقم أكبر من واحد ، وفي مثالنا نهاية الحلقة التكرارية تساوي 3 'المتغير المفترض تخزين الأرقام الناقصة فيه عبارة عن سلسلة نصية فيتم إضافة النصوص التي سبق استخراجها ثم إضافة النصوص الجديدة 'الأرقام الناقصة تساوي قيمة الخلية الحالية 50009 في المثال مضافاً إليها قيمة الحلقة التكرارية والتي هنا تساوي 2 في بداية الحلقة التكرارية ليصبح الناتج 50011 ثم ناقص واحد لتحصل على أول رقم ناقص ألا وهو 5010 'يساوي 3 لتحصل في النهاية على الرقم التالي الناقص ألا وهو 5011[XX]مع الانتقال في الحلقة التكرارية يصبح المتغير                     Text = Text & Val(SH.Range("A" & I)) + XX - 1 & vbCrLf                 Next         End Select     Next 'رسالة لإظهار الأرقام الناقصة     MsgBox Text, vbMsgBoxRtlReading End Sub وإليكم الكود الثاني وهو أقوى في أنه لا يشترط ترتيب الأرقام
    Sub MissingNumbers_YK_A() 'يقوم الكود باستخراج الأرقام الناقصة من سلسلة من الأرقام ولا يشترط ترتيب الأرقام '----------------------------------------------------------------------------     Dim InputRange As Range, OutputRange As Range, ValueFound As Range     Dim LowerVal As Single, UpperVal As Single, Count_I As Single, Count_J As Single     Dim NumRows As Long, NumColumns As Long     Dim Horizontal As Boolean          On Error GoTo ErrorHandler 'النطاق الذي يحتوي سلسلة الأرقام المراد استخراج الأرقام الناقصة منها     Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)     LowerVal = WorksheetFunction.Min(InputRange)     UpperVal = WorksheetFunction.Max(InputRange)     Horizontal = False 'بداية النطاق الذي سيتم استخراج النتائج به     Set OutputRange = Range("E2")          NumRows = OutputRange.Rows.Count     NumColumns = OutputRange.Columns.Count          Application.ScreenUpdating = False         If NumRows < NumColumns Then             Horizontal = True             NumRows = 1         Else             NumColumns = 1         End If                  Count_J = 1                  For Count_I = LowerVal To UpperVal             Set ValueFound = InputRange.Find(Count_I, LookIn:=xlValues, LookAt:=xlWhole)             If ValueFound Is Nothing Then                 If Horizontal Then                     OutputRange.Cells(NumRows, Count_J).Value = Count_I                     Count_J = Count_J + 1                 Else                     OutputRange.Cells(Count_J, NumColumns).Value = Count_I                     Count_J = Count_J + 1                 End If             End If         Next Count_I     Application.ScreenUpdating = True          Exit Sub      ErrorHandler: End Sub كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض
     
    وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً
    Sub MissingNumbers_SALIM() 'يقوم الكود باستخراج الأرقام الناقصة في سلسلة أرقام ولا يشترط الترتيب '------------------------------------------------------------------ 'تعريف المتغيرات     Dim Dico, D     Dim C As Range, Rng As Range     Dim B As Long, I As Long     Dim MinVal As Double, MaxVal As Double 'النطاق المراد استخراج الأرقام الناقصة منه     Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'سطر لايجاد أقل قيمة رقمية في النطاق     MinVal = Application.WorksheetFunction.Min(Rng) 'سطر لايجاد أكبر قيمة رقمية في النطاق     MaxVal = Application.WorksheetFunction.Max(Rng) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به     Range("G2", Range("G2").End(xlDown)).ClearContents 'إنشاء متغير من النوع كائن لتخزين الأرقام الناقصة به     Set Dico = CreateObject("Scripting.Dictionary") 'حلقة تكرارية لكل الأرقام المسلسلة     For I = 1 To (MaxVal - MinVal + 1) 'تعتمد هذه الأسطر على إضافة الرقم الناقص إلى الكائن المخصص لذلك         If Application.WorksheetFunction.CountIf(Rng, MinVal + I - 1) = Then         If Not Dico.Exists(MinVal + I - 1) Then Dico.Add (MinVal + I - 1), (MinVal + I - 1)         End If     Next I 'رقم صف البداية للنتائج في العمود السابع     B = 2 'حلقة تكرارية لوضع القيم التي تم تخزينها في النطاق المحدد     For Each D In Dico.items         Range("G" & B) = D         B = B + 1     Next D End Sub وعشان عيون أحبابي إليكم الكود الرابع وهو أفضل الأكواد من حيث أنه لا يشترط ترتيب الأرقام وأسطر الكود سهلة الفهم وسهلة التعامل معها
    Sub MissingNumbers_YK_B() 'يقوم الكود باستخراج الأرقام الناقصة في تسلسل للأرقام ولا يشترط الترتيب '------------------------------------------------------------------- 'تعريف المتغيرات Dim InputRange As Range Dim X As Long, lRow As Long 'تعيين النطاق الذي سيحتوي على سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("I2:I1000").ClearContents 'حلقة تكرارية من أقل قيمة بالنطاق لأكبر قيمة بالنطاق For X = WorksheetFunction.Min(InputRange) To WorksheetFunction.Max(InputRange) 'استخدام دالة البحث فإذا كانت القيمة المراد البحث عنها غير موجودة يعطي خطأ 'وبناءً على الخطأ يتم تنفيذ السطر التالي If IsError(Application.Match(X, InputRange, )) Then '[I] الرقم 2 هو رقم صف البداية في العمود '[I] يتم وضع الرقم الناقص في الخلية في الصف المحدد في العمود Cells(lRow + 2, "I") = X 'زيادة المتغير بمقدار واحد للانتقال لصف جديد لإدراج الأرقام الناقصة lRow = lRow + 1 End If Next X End Sub أترككم مع الملف المرفق ...للاستفادة بشكل عملي بالكود
    كان معكم أخوكم ياسر خليل أبو البراء YK
    (الموضوع مهدى للأخ الحبيب والأستاذ الكبير أسامة البراوي OB ومهدى للأخ الفاضل نايف - م)
    حمل الملف من هنا
     
    تقبلوا تحياتي
  2. ياسر خليل أبو البراء's post in الترحيل بمعلوميه خليه was marked as the answer   
    السلام عليكم نبدأ بها 
    جرب الكود التالي
    Sub Test() Dim ws As Worksheet, sh As Worksheet, sTarget As String, lr As Long, m As Long, iRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("اذن") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then MsgBox "No Data", vbExclamation: Exit Sub Select Case ws.Range("C2").Value Case "اذن صرف": sTarget = "صرف" Case "اذن اضافه": sTarget = "اضافه" Case Else: MsgBox "No Such Worksheet", vbExclamation: Exit Sub End Select Set sh = ThisWorkbook.Worksheets(sTarget) m = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1 For iRow = 6 To lr sh.Range("A" & m).Resize(, 6).Value = Array(sh.Range("A" & m).Row - 2, ws.Range("E2").Value, ws.Range("C4").Value, ws.Range("C3").Value, ws.Cells(iRow, 1).Value, ws.Cells(iRow, 2).Value) sh.Range("I" & m).Value = ws.Cells(iRow, 4).Value If sh.Name = "اضافه" Then sh.Range("J" & m).Value = ws.Cells(iRow, 5).Value End If m = m + 1 Next iRow Application.ScreenUpdating = True MsgBox "Done", 64 End Sub  
  3. ياسر خليل أبو البراء's post in مطلوب كود vba لنسخ بيانات بعدد معين بخلايا was marked as the answer   
    وعليكم السلام أخي الكريم
    أدرج موديول جديد وضع الدالة المعرفة التالية في الموديول
    Function xDupsV(fCol As Range, Optional offsetCol As Integer = -1) Dim a, r1 As Range, r2 As Range, c As Range, cc As Range, i As Long, j As Long Application.Volatile True Set r1 = fCol Set r2 = r1.Offset(, offsetCol) ReDim a(1 To 1) For Each c In r1 Set cc = c.Offset(, offsetCol) If Not IsEmpty(c) And cc > 0 Then For j = 1 To cc i = i + 1 ReDim Preserve a(1 To i) a(i) = c Next j End If Next c xDupsV = WorksheetFunction.Transpose(a) End Function ثم في الخلية C11 ضع المعادلة بهذا الشكل
    =xdupsv(F3:F6) لا تنسى أن تقوم بمسح النطاق C11 إلى آخر النطاق قبل وضع المعادلة
  4. ياسر خليل أبو البراء's post in تعبئة الليست بوكس باسماء الفولدرات was marked as the answer   
    وعليكم السلام
    جرب الكود التالي
    Private Sub UserForm_Initialize() Dim fso As Object, oFolder As Object, sPath As String, i As Long sPath = "D:\" Set fso = CreateObject("Scripting.FileSystemObject") UserForm1.ListBox1.Clear If fso.FolderExists(sPath) Then Set oFolder = fso.GetFolder(sPath) For Each oFolder In oFolder.SubFolders If Left(oFolder.Name, 1) <> "$" Then i = i + 1 UserForm1.ListBox1.AddItem oFolder.Name End If Next oFolder End If Set fso = Nothing End Sub  
  5. ياسر خليل أبو البراء's post in كود اخفاء عمود يوم الجمعة فقط was marked as the answer   
    غير الجزء التالي
    If Weekday(Cells(4, i)) > 5 ليصبح
    If Weekday(Cells(4, i)) = 6  
  6. ياسر خليل أبو البراء's post in كيفية نقل نصوص من شيت إلى شيت بشرط was marked as the answer   
    وعليكم السلام أخي الكريم
    قم بتغيير اسم الملف المسمى بيانات العاملين 21-9-2023 إلى Employees DB أو قم بتغيير الاسم في الكود (كما يحلو لك)
    ضع الكود التالي في الملف المسمى الإدارة العامة
    Sub Test() Dim a, wb As Workbook, ws As Worksheet, sh As Worksheet, c As Range, dic As Object, sName As String, lr As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set wb = Workbooks.Open(ThisWorkbook.Path & "\Employees DB.xls") Set ws = wb.Worksheets(1) Set sh = ThisWorkbook.ActiveSheet For Each c In ws.Range("C6:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) sName = c.Value If Not dic.Exists(sName) And sName <> Empty Then dic.Add sName, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value) End If Next c wb.Close SaveChanges:=False lr = sh.Cells(Rows.Count, "B").End(xlUp).Row sh.Range("E3:G" & lr).ClearContents For Each c In sh.Range("B3:B" & lr) sName = c.Value If dic.Exists(sName) Then a = dic(sName) c.Offset(, 3).Resize(, 3).Value = a End If Next c Application.ScreenUpdating = True End Sub  
  7. ياسر خليل أبو البراء's post in الترقيم كالتسلسل بشروط was marked as the answer   
    جرب الكود التالي عله يفي بالغرض بإذن الله
    Sub Test() Dim x, ws As Worksheet, lr As Long, i As Long, j As Long, startSeq As Long, endSeq As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row ws.Range("A2:A" & lr).ClearContents For i = 2 To lr j = 0 x = Application.Match(ws.Cells(i, "L").Value, ws.Columns("T"), 0) If Not IsError(x) Then startSeq = ws.Cells(x, "U").Value endSeq = ws.Cells(x, "V").Value Do j = j + 1 ws.Cells(i + j - 1, "A").Value = startSeq If startSeq > endSeq Then ws.Cells(i + j - 1, "A").Value = Empty startSeq = startSeq + 1 Loop Until ws.Cells(i, "L").Value <> ws.Cells(i + j, "L").Value i = i + j - 1 End If Next i Application.ScreenUpdating = True End Sub إذا قمت بحذف صفوف من البيانات سيلزمك تنفيذ الكود من جديد لضبط التسلسل
  8. ياسر خليل أبو البراء's post in ترحيل البيانات التى يتم تحديدها فقط عن طريق ال Check Box was marked as the answer   
    وعليكم السلام أخي الكريم ياسر
    جرب الكود التالي عله يفي بالغرض بإذن الله
    تم الاعتماد على العمود R في الورقة الثانية لتسجيل اسم Check Box الذي تم ترحيله تفادياً لترحيله مرة أخرى .. يمكنك إخفاء العمود أو إخفاء القيم في العمود R
    Sub Test() Dim x, ws As Worksheet, sh As Worksheet, chkBox As CheckBox, r As Long, m As Long, cnt As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets(1) Set sh = ThisWorkbook.Sheets(2) For r = 3 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set chkBox = ws.Shapes("Check Box " & r - 2).OLEFormat.Object x = Application.Match(chkBox.Name, sh.Columns("R"), 0) If IsError(x) Then If chkBox.Value = 1 Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & m).Resize(, 17).Value = ws.Range("A" & r).Resize(, 17).Value sh.Range("R" & m).Value = chkBox.Name cnt = cnt + 1 End If End If Next r Application.ScreenUpdating = True If cnt > 0 Then MsgBox "Total = " & cnt, 64 Else MsgBox "Nothing Transferred", vbExclamation End Sub  
  9. ياسر خليل أبو البراء's post in محتاج كود لتلوين اسماء الشيتات was marked as the answer   
    السلام عليكم أخي الكريم
    جرب الكود التالي في حدث المصنف ThisWorkbook
    Private Sub Workbook_NewSheet(ByVal Sh As Object) Dim R As Integer, G As Integer, B As Integer Randomize R = Int(Rnd() * 256) G = Int(Rnd() * 256) B = Int(Rnd() * 256) Sh.Tab.Color = RGB(R, G, B) End Sub سيعمل الكود فقط عند إضافة ورقة عمل جديدة
  10. ياسر خليل أبو البراء's post in كود حفظ pdf بعد اجراء تصفيه was marked as the answer   
    أخي الكريم
    ضع الكود التالي في موديول عادي
    من هنا
    Sub Test() Dim myFile As String Dim lRow As Long Sheets("Sheet1").Range("A5:E25").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet1").Range("C1:C2"), CopyToRange:=Sheets("Sheet2").Range("A6:E6"), Unique:=False myFile = "D:\Print\" & Sheets(2).Range("G4").Text & "-" & Sheets(1).Range("L3").Text & ".pdf" lRow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1 Sheets(2).ExportAsFixedFormat Type:=xlTypePDF, Filename:=myFile MsgBox "Done...", 64 End Sub ثم ضع الكود التالي في حدث الفورم
    Private Sub CommandButton1_Click() Test End Sub تقبل تحياتي
     
  11. ياسر خليل أبو البراء's post in جلب بيانات من ملف نصي was marked as the answer   
    مرحباً بك بين إخوانك في منتدى أوفيسنا

    أنشئ ملف نصي بالمفكرة وقم بحفظه واجعل Encoding إلى Unicode

    ثم من التبويب Data اختر الأمر From Text ( أوفيس 2007 )
    ثم اتبع التعليمات Next حتى Finish

    عاشق الإكسيل
  12. ياسر خليل أبو البراء's post in تحويل الأرقام الى ساعات ودقائق was marked as the answer   
    أخي الكريم
    إليك الحل في الملف المرفق
    دمت على طاعة الله
    أرجو منك الدعاء بظهر الغيب

    عاشق الإكسيل
    Time_Function.rar
  13. ياسر خليل أبو البراء's post in نسخ ولصق البيانات على نطاق تمت فلترته was marked as the answer   
    الأخ الحبيب العمري
    الأخوة تعبوا معاك
    ياريت ترفق ملف بعد كدا لو حبيت تطرح مشكلة حتى تتضح المشكلة تماماً للأخوة الأعضاء
    عموماً ..إليك الملف التالي فيه شرح لكيفية نسخ ولصق البيانات على نطاق تمت فلترته...
    لو كانت البيانات ثابته كما في شرحك فالموضوع سهل كل ما عليك أن تحدد النطاق المفلتر ثم f5 ثم special ثم Visible cells only ثم تقوم بتحرير الخلية الأولى ثم أخيراً Ctrl+Enter
    أما إذا كانت البيانات المراد لصقها متغيرة فهذا مبين بالشرح
    أخوك أبو البراء
    PasteOverFilteredRange.rar
  14. ياسر خليل أبو البراء's post in معادلة SUMPRODUCT was marked as the answer   
    وهذه معادلة أخرى أخف من الأولى


    =SUMPRODUCT((SUM($A$1:$A$4)*($B$1:$B$4)))

    لا تنسانا من صالح الدعاء
    أخوك أبو البراء
  15. ياسر خليل أبو البراء's post in تعقب التغيرات في الدرجات مع ذكر اسم الطالب was marked as the answer   
    أخي الكريم
    لم تجب على سؤالي ، ولم توضح التفاصيل ، لأن التفاصيل دائما مهمة ....
     
    عموما تفضل المرفق
    أضفت عمود لكل مادة بحيث تعرف المادة التي تم التغيير فيها
    Target VBA.rar
  16. ياسر خليل أبو البراء's post in كود للمقارنه بين شيتين was marked as the answer   
    أخي الكريم خالد جرب الكود التالي عله يفي بالغرض (طبعاً يوضع الكود في المصنف المسمى PickList) ويحفظ بامتداد xlsm ... قم بفتح الملف الأول والملف الجديد الذي قمت بحفظه بامتداد xlsm ونفذ الكود وستظهر النتائج في العمود الثاني في الملف الجديد المسمى PickList.xlsm
    Sub Test() Dim swb As Workbook Dim twb As Workbook Dim arr1 As Variant Dim arr2 As Variant Dim v As Variant Dim d As Object Dim m As Long Dim n As Long Dim r0 As Long Dim r As Long Dim s As Long Dim c As Long Set swb = Workbooks("SerializePlantStockReport.xlsx") Set twb = ThisWorkbook Set d = CreateObject("Scripting.Dictionary") m = swb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row arr1 = swb.Sheets(1).Range("C2:E" & m).Value n = twb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row arr2 = twb.Sheets(1).Range("A2:B" & n).Value For s = 1 To n - 1 v = arr2(s, 1) If d.exists(v) Then r0 = d(v) Else r0 = 0 End If For r = r0 + 1 To m If arr1(r, 1) = v Then arr2(s, 2) = CStr(arr1(r, 3)) d(v) = r Exit For End If Next r Next s twb.Sheets(1).Range("A2:B" & n).Value = arr2 End Sub  
  17. ياسر خليل أبو البراء's post in تصفية حساب العميل (فاتورة جديد) وعدم استدعاء الفاتورة القديمة was marked as the answer   
    تفضل أخي الفاضل أبو نبأ الملف التالي ..جرب الملف ووافنا بالنتائج
     
    Client Account Report YasserKhalil V3.rar
  18. ياسر خليل أبو البراء's post in مشكلة عدم تشغيل الاكسل على ويندوز 7 والاوفيس 2007و2010و2013 was marked as the answer   
    روح لمحرر الأكواد ومن Tools اختر References وشوف المكتبات اللي بجوارها كلمة Missing وشيل علامة الصح
  19. ياسر خليل أبو البراء's post in خلية امتداد was marked as the answer   
    جرب المعادلة
    =SUMIF('2'!A4:A7,C3,INDIRECT("'" & E2))  
  20. ياسر خليل أبو البراء's post in وضع عنوان الخلية كقيمة في متغير was marked as the answer   
    أخي الكريم إليك الكود فيه حل للمشكلة
    Sub Store_ActiveCell_In_Variable_Go_Back_At_The_End() Dim c As Range Set c = ActiveCell 'Your Macro Application.Goto Range("K35") Application.Wait Now + TimeValue("00:00:03") Application.Goto c End Sub  
  21. ياسر خليل أبو البراء's post in طلب مساعدة في كود او معادلة تجميع بيانات was marked as the answer   
    وعليكم السلام أخي الكريم زياد
    جرب الكود التالي في حدث ورقة العمل المراد التجميع فيها
    قم بكتابة القسم في العمود الثاني ..
    Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim xf As Variant If Target.Cells.Count > 1 Then Exit Sub If Target.Row > 3 And Target.Column = 2 Then Application.EnableEvents = False If Target = "" Then Target.Offset(, -1).ClearContents: Target.Offset(, 1).Resize(, 6).ClearContents: GoTo Skipper For Each ws In ThisWorkbook.Worksheets(Array("وحدة الانتاج", "وحدة النقل", "وحدة التوزيع")) xf = Application.Match(Target, ws.Columns(2), 0) If IsNumeric(xf) Then Target.Offset(, -1) = Target.Row - 3 Target.Offset(, ws.Index * 2 - 1) = ws.Cells(xf, 3) Target.Offset(, ws.Index * 2) = ws.Cells(xf, 4) End If Next ws Skipper: Application.EnableEvents = True End If End Sub  
  22. ياسر خليل أبو البراء's post in المساعدة في جعل الخلية خاوية يطبق عليها الدالة اذا كان هناك قيمة في خلية اخري was marked as the answer   
    جرب الكود التالي 
    Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 7 And Target.Column = 5 Then Application.EnableEvents = False On Error GoTo Skipper If Target.Value = "" Then Target.Offset(, 1) = "" Target.Offset(, 1) = Application.WorksheetFunction.VLookup(Target, Range("I8:J20"), 2, False) Skipper: Application.EnableEvents = True End If End Sub  
  23. ياسر خليل أبو البراء's post in اريد نسخ بيانات في Label was marked as the answer   
    Private Sub UserForm_Activate() Dim i As Long For i = 17 To 32 Me.Controls("Label" & i) = Range("C" & i - 14) Next i For i = 37 To 42 Me.Controls("Label" & i) = Range("D" & i - 34) Next i End Sub  
  24. ياسر خليل أبو البراء's post in طلب كود ترحيل لأعمدة غير متتالية وغير مرتبة was marked as the answer   
    أخي الكريم ..
    إليك الكود التالي .. لا حاجة للاحتفاظ بالمعادلات في ورقة الهدف (النتائج) .. حيث وضعت لك دوال معرفة تقوم بنفس المهمة .. وتوفر عليك عناء كتابة وضبط المعادلات ..
    أدرج موديول جديد .. ثم ضع الكود التالي وجرب الكود وأخبرنا بالنتائج
    Option Explicit Sub TransferDataUsingArrays() Const startDate As Date = #10/1/2017# Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim temp As Variant Dim birthDate As Date Dim i As Long Dim j As Long Dim p As Long Set ws = Sheets("بيانات الطلاب") Set sh = Sheets("سجل 41 مستجدين") arr = ws.Range("B17:T" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value ReDim temp(1 To UBound(arr, 1), 1 To 18) For i = 1 To UBound(arr, 1) If arr(i, 5) = "مستجد" Or arr(i, 5) = "مستجدة" Then p = p + 1 For j = 1 To 18 temp(p, j) = arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 7, 8, 9, 13, 4, 14, 15, 16, 2, 11, 12, 17)) Next j temp(p, 1) = p On Error Resume Next birthDate = CDate(temp(p, 3) & "/" & temp(p, 4) & "/" & temp(p, 5)) temp(p, 7) = CalculateAge(birthDate, startDate, "d") temp(p, 8) = CalculateAge(birthDate, startDate, "m") temp(p, 9) = CalculateAge(birthDate, startDate, "y") On Error GoTo 0 temp(p, 15) = KhFatherName(CStr(temp(p, 2))) End If Next i If p > 0 Then With sh.Range("B8") .Resize(1000, UBound(temp, 2)).ClearContents .Resize(p, UBound(temp, 2)).Value = temp End With End If End Sub Function KhFatherName(ByVal Name As String) As String Dim khString As String Dim searchChar As String Dim khMid As String Dim khRep As String Dim khMyNo As Integer On Error GoTo Err_KhFatherName If IsEmpty(Name) Then GoTo Err_KhFatherName khString = KhFatherReplace(Trim(Name)) & " " searchChar = " " khMyNo = InStr(1, khString, searchChar, 1) khMid = Trim(Mid(khString, khMyNo, Len(khString))) khRep = Replace(khMid, "_", " ") KhFatherName = khRep Exit Function Err_KhFatherName: KhFatherName = "" End Function Private Function KhFatherReplace(ByVal Kh_Sub As String) As String Dim myArray As Variant Dim ar As Variant Dim sn As String Dim re As String myArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", " الزهراء") sn = Kh_Sub For Each ar In myArray re = Replace(ar, " ", "_") sn = Replace(sn, ar, re) Next ar KhFatherReplace = sn End Function Function CalculateAge(birth As Variant, start As Variant, str As String) Dim y As Long Dim m As Long Dim d As Long If Not IsDate(birth) Or Not IsDate(start) Then GoTo Skipper m = DateDiff("m", birth, start) d = DateDiff("d", DateAdd("m", m, birth), start) If d < 0 Then m = m - 1 d = DateDiff("d", DateAdd("m", m, birth), start) End If y = m \ 12 m = m Mod 12 Select Case str Case "d" CalculateAge = d Case "m" CalculateAge = m Case "y" CalculateAge = y End Select Exit Function Skipper: CalculateAge = "" End Function  
  25. ياسر خليل أبو البراء's post in جمع عمود من الاسماء في Label was marked as the answer   
    وعليكم السلام أخي محمد
    جرب الكود التالي
    Private Sub UserForm_Initialize() Label2 = Application.WorksheetFunction.COUNTA(Range("B2:B200")) End Sub  
×
×
  • اضف...

Important Information