محمد هشام.

بعد إدن الأستاد @عبدالله بشير عبدالله تعديل بسيط على الكود الخاص به أخي @reem2009a جرب بهذه الطريقة لا تحتاج لتحديد مسار سطح المكتب. عند تنفيذ الكود سيفتح لك مربع حوار لإختار ملف رقم1 وملف رقم2 مما سيغنيك عن تحديد أسماء المصنفات داخل الكود ربما يناسبك filePath1 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select First File") If filePath1 = "False" Then Exit Sub filePath2 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select Second File") If filePath2 = "False" Then Exit Sub On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(filePath1) Set wb2 = Workbooks.Open(filePath2) Set resultWs = ThisWorkbook.Sheets("Sheet1") resultWs.Cells.ClearContents resultWs.Range("A1:D1").Value = Array("اسم الموظف", "الحالة", _ Left(wb1.Name, InStrRev(wb1.Name, ".") - 1), Left(wb2.Name, InStrRev(wb2.Name, ".") - 1)) 'Code........... End Sub نتائج المقارنة.xlsb

Private Sub ListBox1_Click() Dim i As Byte, Clé As Variant Dim WS As Worksheet, ColF As Range Dim Colstar As Integer, ColEnd As Integer Set WS = Sheets("البداية") Colstar = 3 ColEnd = 14 For i = 0 To 11 Controls("TextBox" & (i + 1)).Value = IIf(ListBox1.ListIndex <> -1, ListBox1.Column(i), "") Next i Clé = TextBox4.Value Set ColF = WS.Columns("F").Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole) If Not ColF Is Nothing Then WS.Activate WS.Range(WS.Cells(ColF.row, Colstar), WS.Cells(ColF.row, ColEnd)).Select End If End Sub With ComboBox1 .Clear .AddItem "رقم الملف": .AddItem "الفاحص": .AddItem "اسم المراجع" End With UserForm_Initialize TextBox13.Value = "": ComboBox1.Value = "" Label15.Caption = "" تعديل فورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Dim i As Integer Dim WS As Worksheet: Set WS = Sheet5 For i = 2 To 30 WS.Cells(i - 1, 3).Value = Me.Controls("TextBox" & i).Value Next i

أخي @المغفوري 1 ) الرموز الظاهرة معك ليست خطأ هده رسالة (تم التعديل بنجاح ) لحل مشكلة طلاسم اللغة العربية عليك مراجعة ظبط اعدادات اللغة العربية على جهازك 2) الكود مفاده إذا تم العثور على مطابقة للإسم يتم تحديث البيانات (من العمود B إلى L ) صراحة لا أعلم ما تحاول فعله بالظبط حاول تجربة الكود المقترح في المشاركة السابقة بعد تعديله ووافينا بالنتيجة متابعة الطلاب.xlsb

ادن جرب هدا Option Explicit Sub UpdateData() Dim WS As Worksheet, F As Worksheet Dim i As Long, j As Long, a As Long Dim Clé As Long, found As Boolean, modified As Boolean Set WS = Sheet1 ' <<=== ' 'Worksheets("بيانات الطلاب") Set F = Sheet3 ' <<=== ' 'Worksheets("متابعة الطلاب") Clé = 1 ' <<=== ' الاسم ( يمكنك تعديله بما يناسبك )' عمود الشرط Application.ScreenUpdating = False modified = False For i = 4 To F.Cells(F.Rows.Count, Clé).End(xlUp).Row Dim tmp As String: tmp = F.Cells(i, Clé).Value found = False For j = 3 To WS.Cells(WS.Rows.Count, Clé).End(xlUp).Row If WS.Cells(j, Clé).Value = tmp Then For a = 2 To 12 WS.Cells(j, a).Value = F.Cells(i, a).Value Next a found = True modified = True Exit For End If Next j If Not found Then Debug.Print "No match for: " & tmp End If Next i Application.ScreenUpdating = True If modified Then MsgBox "Updated successfully", vbInformation End Sub

نعم اخي @المغفوري هي عبارة عن استعلام لاكن ادا كنت تقصد انك ترغب بعد استدعائها ان تقوم بتعديلها مثلا وتحديثها على ورقة بيانات الطلاب جرب هدا Option Explicit Sub UpdateData() Dim WS As Worksheet, F As Worksheet, i As Long, j As Long Dim n As Boolean Set WS = Worksheets("بيانات الطلاب") Set F = Worksheets("متابعة الطلاب") If F.Cells(F.Rows.Count, 1).End(xlUp).Row < 4 Then Exit Sub Application.ScreenUpdating = False n = False For i = 4 To F.Cells(F.Rows.Count, 1).End(xlUp).Row For j = 3 To WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If WS.Cells(j, 1).Value = F.Cells(i, 1).Value Then WS.Cells(j, 2).Resize(, 10).Value = F.Cells(i, 2).Resize(, 10).Value n = True Exit For End If Next j Next i Application.ScreenUpdating = True If n Then MsgBox "تم التعديل بنجاح", vbInformation, "تأكيد" End If End Sub متابعة الطلاب.xlsb

تفضل أخي @mk_mk_79 Sub CopyHeaders() Dim lastRow As Long, tmp As Long Dim n As Long, Irow As Long, ColArr As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row Irow = 9 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Range("W" & Irow & ":Y" & WS.Rows.Count).ClearContents tmp = 7 Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then ColArr = Array(WS.Cells(tmp, "F").Value, _ WS.Cells(tmp, "L").Value, WS.Cells(tmp, "R").Value) n = 0 Do While tmp + n <= lastRow And _ (Not IsEmpty(WS.Cells(tmp + n, "F")) Or _ Not IsEmpty(WS.Cells(tmp + n, "L")) Or _ Not IsEmpty(WS.Cells(tmp + n, "R"))) n = n + 1 Loop With WS.Range(WS.Cells(Irow, "W"), WS.Cells(Irow + n - 1, "W")) .Value = ColArr(0) .Offset(0, 1).Value = ColArr(1) .Offset(0, 2).Value = ColArr(2) End With Irow = Irow + n + 3 tmp = tmp + n Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub طلبات v2 .xls

وعليكم السلام ورحمة الله تعالى وبركاته إليك المثال التالي أقل تاريخ.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub CopyHeaders() Dim lastRow As Long, tmp As Long, Irow As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row tmp = 7 Irow = 2 WS.Range("W8:Y" & WS.Rows.Count).ClearContents Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then With WS.Cells(tmp + Irow, "W") .Value = WS.Cells(tmp, "F").Value .Offset(0, 1).Value = WS.Cells(tmp, "L").Value .Offset(0, 2).Value = WS.Cells(tmp, "R").Value End With Do While tmp <= lastRow And _ (Not IsEmpty(WS.Cells(tmp, "F")) Or Not _ IsEmpty(WS.Cells(tmp, "L")) Or Not IsEmpty(WS.Cells(tmp, "R"))) tmp = tmp + 1 Loop Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True End Sub طلبات (1).xls

Function irow(ws As Worksheet, tmp As String) As Long Dim lastrow As Long, i As Long lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row For i = 7 To lastrow If ws.Cells(i, 5).Value = tmp Then irow = i Exit Function End If Next i irow = -1 End Function تعديل Private Sub CommandButton2_Click() Dim ws As Worksheet, linge As Long, i As Long Dim ColArr As Variant, arr() As Variant Set ws = ThisWorkbook.Sheets("البداية") Dim tmp As String: tmp = Me.TextBox3.Value If tmp = "" Then: MsgBox "الرجاء إدخال رقم الملف", vbExclamation, "خطأ": Exit Sub linge = irow(ws, tmp) If linge = -1 Then: MsgBox "رقم الملف غير موجود", vbExclamation, "خطأ": TextBox3.SetFocus: Exit Sub If MsgBox("هل أنت متأكد أنك تريد تعديل بيانات " & Me.TextBox4.Value & "؟", vbYesNo + vbQuestion, "تأكيد") = vbYes Then ColArr = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") arr = Array(Me.TextBox1.Value, Me.TextBox2.Value, Me.TextBox3.Value, _ Me.TextBox4.Value, Me.TextBox5.Value, Me.TextBox6.Value, _ Me.TextBox7.Value, Me.TextBox8.Value, Me.TextBox9.Value, _ Me.TextBox10.Value, Me.TextBox11.Value, Me.TextBox12.Value) Application.ScreenUpdating = False For i = LBound(arr) To UBound(arr) If i <= UBound(ColArr) Then ws.Cells(linge, ColArr(i)).Value = arr(i) End If Next i UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم تعديل البيانات بنجاح", vbInformation End If End Sub ترحيل Private Sub CommandButton1_Click() Dim ws As Worksheet, lastrow As Long Dim arr() As Variant, ColArr As Variant, tmp As String Set ws = ThisWorkbook.Sheets("البداية") lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row tmp = Me.TextBox3.Value If tmp = "" Then MsgBox "الرجاء إدخال رقم الملف", vbExclamation, "خطأ": Exit Sub If TextBox4.Value = "" Then MsgBox "يرجى ادخال اسم صاحب المعاش", vbExclamation: TextBox4.SetFocus: Exit Sub If TextBox6.Value = "" Then MsgBox "يرجى ادخال اسم الفاحص", vbExclamation: TextBox6.SetFocus: Exit Sub If WorksheetFunction.CountIf(ws.Range("E7:E" & lastrow), tmp) > 0 Then MsgBox "رقم الملف موجود بالفعل", vbExclamation, "تكرار رقم الملف": Exit Sub End If ColArr = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") arr = Array(Me.TextBox1.Value, Me.TextBox2.Value, tmp, TextBox4.Value, _ Me.TextBox5.Value, TextBox6.Value, Me.TextBox7.Value, _ Me.TextBox8.Value, Me.TextBox9.Value, Me.TextBox10.Value, _ Me.TextBox11.Value, Me.TextBox12.Value) Application.ScreenUpdating = False For i = LBound(arr) To UBound(arr) ws.Cells(lastrow + 1, ColArr(i)).Value = arr(i) Next i With ws.Range("C7:C" & ws.Cells(ws.Rows.Count, "D").End(xlUp).row) .Value = Evaluate("ROW(" & .Address & ")-6") End With For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" Next ctrl UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم إدخال البيانات بنجاح", vbInformation, "نجاح" End Sub تعديل فورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Dim f, Rng, wsData() Private Sub UserForm_Initialize() Dim f As Worksheet, Rng As Range Dim wsData As Variant, i As Long Set f = Sheets("البداية") Set Rng = f.Range("C7:N" & f.Cells(f.Rows.Count, "E").End(xlUp).row) wsData = Rng.Value For i = LBound(wsData, 1) To UBound(wsData, 1) Dim j As Long For j = 2 To 11 If IsDate(wsData(i, j)) Then wsData(i, j) = Format(wsData(i, j), "yyyy/mm/dd") Next j Next i With ListBox1 .ColumnWidths = "35;70;65;100;110;65;70;75;70;70;70;100" .ColumnCount = 12: .Font.Size = 9: .Font.Name = "Mudir MT" .List = wsData End With With ComboBox1 .AddItem "رقم الملف": .AddItem "الفاحص": .AddItem "اسم المراجع" End With 'Code............. End Sub Private Sub ListBox1_Click() Dim i As Byte, Rng As Long Dim Colstar As Integer, ColEnd As Integer Dim ws As Worksheet: Set ws = Sheets("البداية") Colstar = 4: ColEnd = 14 If ListBox1.ListIndex = -1 Then MsgBox "يرجى اختيار صف من القائمة", vbExclamation Exit Sub End If For i = 0 To 11 If IsDate(ListBox1.Column(i)) Then Controls("TextBox" & i + 1).Value = Format(ListBox1.Column(i), "yyyy/mm/dd") Else Controls("TextBox" & i + 1).Value = ListBox1.Column(i) End If Next i TextBox15.Value = ListBox1.ListIndex + 1 Rng = ListBox1.ListIndex + 7 With ws .Activate .Range(.Cells(Rng, Colstar), .Cells(Rng, ColEnd)).Select End With End Sub تعديل فورم.rar

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا مما تحاول فعله لاكن جرب هدا =IF(OR(F23="الأول", F23="الثاني"), IF(COUNTIF($B$11:$I$15, "ق") >= 25, 25, COUNTIF($B$11:$I$15, "ق")), COUNTIF($B$11:$I$15, "ق")) او =IF(OR(F23="الأول", F23="الثاني"), MIN(25, COUNTIF($B$11:$I$15, "ق")), COUNTIF($B$11:$I$15, "ق"))

إدن لنفترض أننا سنقوم باستخراج البيانات من الأعمدة H:M كما هو ظاهر لديك على الصورة إلى ورقة 2 مثلا Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "الإســـم": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then kay = (cell.Column - 9) & " مخزن" Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Colors(cell As Range, color As Long) With cell .Interior.color = color .Font.Bold = True .Borders(xlEdgeBottom).LineStyle = xlContinuous End With End Sub New.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته في الخلية A4 ضع احدى المعادلات التالية مع سحبها يسارا لغاية عمود L وسحبها أسفل لغاية الصف الدي يناسبك =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, SMALL(IF('بيانات الطلاب'!$B$3:$B$100=$B$1, ROW('بيانات الطلاب'!$B$3:$B$100)-ROW('بيانات الطلاب'!B$3)+1), ROW(1:1))), "") أو =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, AGGREGATE(15, 6, ROW('بيانات الطلاب'!$B$3:$B$100) -ROW('بيانات الطلاب'!B$3)+1/( 'بيانات الطلاب'!$B$3:$B$100=$B$1), ROW(1:1))), "") أو =FILTER('بيانات الطلاب'!A$3:A$100, 'بيانات الطلاب'!$B$3:$B$100 = $B$1) متابعة الطلاب.xlsx باستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Long, j As Long, clé As String, IRow As Long, col As Long Dim WS As Worksheet: Set WS = Worksheets("بيانات الطلاب") Dim F As Worksheet: Set F = Worksheets("متابعة الطلاب") If Not Intersect(Target, Me.Range("B1")) Is Nothing Then d = 4 clé = F.Range("B1").Value IRow = WS.Range("B3:B" & WS.Rows.Count).Find("*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Application.ScreenUpdating = False F.Range("A4:L" & F.Rows.Count).ClearContents For j = 3 To IRow If WS.Cells(j, 2).Value = clé Then For col = 1 To 12 F.Cells(d, col).Value = WS.Cells(j, col).Value Next col d = d + 1 End If Next j Application.ScreenUpdating = True End If End Sub متابعة الطلاب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الإسم =IFERROR(INDEX(A!B$3:B$1000, SMALL(IF(A!$A$3:$A$1000=$E$4, ROW(A!$A$3:$A$1000)-ROW(A!$A$3)+1), ROW()-5)), "") التشخيصي =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0)), "") التقويم =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0) + 1), "") A.xlsx

تم تنفيذها بواسطة كود vba يرجى إرفاق عينة لشكل البيانات لديك لتحديد النطاقات بشكل صحيح ومكان وضع النتائج المطلوبة تفاديا للأخطاء

هل تقصد ان جدول البيانات 2/ النوع و الجهة موجودة مسبقا على الجدول فقط يتم تجميع الأرقام و الشرط: عدم تكرار نفس النوع والجهة معاً ادا كان هدا ما تقصده يكفي وضع المعادلة التالية في عمود H =IF(AND(G4<>"", F4<>""), IFERROR(SUMIFS(D4:D100, C4:C100, G4, B4:B100, F4), ""), "") أما إدا كنت ترغب باستخراج البيانات بالشكل الواضح في الصورة بدون وضع بيانات مسبقا استخدم الكود التالي في حدث ورقة 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Set rng = Intersect(Target, Me.Range("B4:D" & Me.Rows.Count)) If Not rng Is Nothing Then TotalNonTri End If End Sub Sub TotalNonTri() Dim a() As Variant, i&, lig&, key As Variant, tmp As Variant Dim WS As Worksheet, d As Object, tbl As Variant, n As String Set d = CreateObject("Scripting.Dictionary") Set WS = Sheets("Sheet1") tbl = Range("B4:D" & Cells(Rows.Count, "B").End(xlUp).Row).Value Application.ScreenUpdating = False WS.Range("F4:H" & WS.Rows.Count).ClearContents For i = LBound(tbl, 1) To UBound(tbl, 1) If Not IsEmpty(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then n = tbl(i, 1) & "|" & tbl(i, 2) If d.Exists(n) Then d(n) = d(n) + tbl(i, 3) Else d(n) = tbl(i, 3) End If End If Next i ReDim a(1 To d.Count, 1 To 3) lig = 1 For Each key In d.Keys tmp = Split(key, "|") a(lig, 1) = tmp(0): a(lig, 2) = tmp(1): a(lig, 3) = d(key) lig = lig + 1 Next key With Range("F4").Resize(d.Count, UBound(a, 2)) .Value = a End With Application.ScreenUpdating = True End Sub Book1.xlsb

اخي @mahmoud nasr alhasany لا افهم مادا تقصده لقد تم الاجابة عن طلبك في اول مشاركة الان نتفاجئ ب حساب الأوزان النسبية واشياء اخرى لم تكن ضمن طلبك اول مرة فهدا لا علاقة له بموضوعنا وكدالك تفاديا لكثرة التعديلات سأنسحب ربما يستطيع أحد الإخوة مساعدتك

جرب هدا هل يناسبك توزيع فئات نقدية.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 1) يصعب التعامل مع الصور اخي الكريم المفروض إرفاق ملف للاشتغال عليه 2) الصورة المرفقة للنتائج المطلوبة تتضمن فقط مخزن 1 ومخزن 2 اين هو 3 و4 3) عدم تحديد مكان وضع النتائج على حسب ما فهمت من طلبك المفروض النتيجة المتوقعة تكون على الشكل التالي

ادن جرب هدا Private Sub CommandButton24_Click() Dim a(2) As Long, b(2) As Double, arr As Variant Dim total(1) As Double, sum As Double, i As Integer arr = Array(200, 100, 50) For i = 0 To 2 If Not IsNumeric(Controls("TextBox" & (i + 1)).Value) Or Val(Controls("TextBox" & (i + 1)).Value) <= 0 Then MsgBox "الرجاء إدخال أعداد صحيحة موجبة فقط": Exit Sub End If a(i) = Val(Controls("TextBox" & (i + 1)).Value) b(i) = a(i) / 2 Controls("TextBox" & (4 + i)).Value = Int(b(i)) Controls("TextBox" & (7 + i)).Value = a(i) - Controls("TextBox" & (4 + i)).Value Controls("TextBox" & (16 + i)).Value = Controls("TextBox" & (4 + i)).Value * arr(i) Controls("TextBox" & (19 + i)).Value = Controls("TextBox" & (7 + i)).Value * arr(i) total(0) = total(0) + Controls("TextBox" & (16 + i)).Value total(1) = total(1) + Controls("TextBox" & (19 + i)).Value Next i sum = total(0) + total(1) If sum <> 0 Then Controls("TextBox11").Value = Format(total(0), "$#,##0.00") Controls("TextBox12").Value = Format(total(1), "$#,##0.00") Controls("TextBox10").Value = Format(sum, "$#,##0.00") Else MsgBox "حدث خطأ: الإجمالي الكلي يساوي صفرًا" End If Me.TextBox58 = Val(TextBox1) + Val(TextBox2) + Val(TextBox3) Me.TextBox59 = Val(TextBox4) + Val(TextBox5) + Val(TextBox6) Me.TextBox60 = Val(TextBox7) + Val(TextBox8) + Val(TextBox9) MsgBox "تم التوزيع بنجاح" End Sub توزيع فئات نقدية.xlsm

.

ضع الأكواد التالية في حدث ورقة natiga Private Sub Worksheet_Activate() UpdateData End Sub '============ Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("A10:A25")) Is Nothing Then UpdateData End If End Sub '=========== Private Sub UpdateData() Dim ColmA As Variant, msg As String, i As Long, tmp As Variant, col As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Feuil1") Dim item As Range: Set item = WS.Range("K2:K9") Dim data As Range: Set data = WS.Range("L2:O9") For i = 10 To 25 ColmA = Me.Range("A" & i).Value Me.Range("B" & i).ClearContents If Trim(ColmA) = "" Then GoTo lig On Error Resume Next tmp = Application.Match(ColmA, item, 0) On Error GoTo 0 If Not IsError(tmp) Then msg = "بدون نتيجة" For col = data.Columns.Count To 1 Step -1 If Trim(data.Cells(tmp, col).Value) <> "" Then msg = data.Cells(tmp, col).Value Exit For End If Next col Me.Range("B" & i).Value = msg Else Me.Range("A" & i).Resize(1, 2).ClearContents MsgBox "الكود " & ColmA & " غير موجود", vbExclamation End If lig: Next i End Sub المعادلة =IF(A10="","",IFERROR(LOOKUP(2,1/(INDEX(Feuil1!$L$2:$O$9, MATCH(A10,Feuil1!$K$2:$K$9,0),0)<>""),INDEX(Feuil1!$L$2:$O$9,MATCH(A10,Feuil1!$K$2:$K$9,0),0)),"بدون نتيجة")) ppp7.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub Copier_tbl_Employe() Dim Code As String, lastrow As Long, n As Boolean Dim WS As Worksheet, dest As Worksheet Dim ColB As Variant, i As Long, tmp As Long Set WS = ThisWorkbook.Sheets("المصدر") Set dest = ThisWorkbook.Sheets("الهدف") tmp = 16: Code = dest.[B5].Value If Code = "" Then: MsgBox "الرجاء إدخال رقم الموظف", vbExclamation: Exit Sub lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row ColB = WS.Range("B1:B" & lastrow).Value n = False For i = 1 To UBound(ColB) If ColB(i, 1) = Code Then n = True Exit For End If Next i Application.ScreenUpdating = False If n Then With dest.Range("A5:I20") .UnMerge .ClearContents End With WS.Range("A" & i & ":I" & i + tmp).Copy With dest.Range("A5") .PasteSpecial Paste:=xlPasteAll End With Else MsgBox "لم يتم العثور على رقم الموظف : " & Code, vbExclamation End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub جلب بيانات اعتمادا على رقم الموظف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك ذالك بتعديل كود إفراغ البيانات السابقة بهذا الشكل فقط ليتجاهل إفراغ عمود M With Union(sh.Range("K6:L64"), sh.Range("P6:Q64")) .FormatConditions.Delete .ClearContents End With لتضمينها داخل الكود With sh .Range("M3").Formula = "=COUNTIF(M6:M37, ""حضور"") + COUNTIF(R6:R37, ""حضور"")" .Range("N3").Formula = "=COUNTIF(M6:M37, ""غياب"") + COUNTIF(R6:R37, ""غياب"")" .Range("P3").Formula = "=COUNTIF(M6:M37, ""اجازة"") + COUNTIF(R6:R37, ""اجازة"")" .Range("Q3").Formula = "=IF(SUM(N6:N37, S6:S37) = 0, """", SUM(N6:N37, S6:S37))" End With COUNTIF.xlsm