محمد هشام.

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الأستاد @عبدالله بشير عبدالله تفضل جرب هدا بدون الحاجة لتغيير أسماء أوراق العمل Option Explicit Sub test() Dim Sh As Worksheet, WS As Worksheet: Set WS = Worksheets("واردالمنطقة") Dim iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, Updated As Boolean Dim tmp As String, j As Boolean, cell As Range, WSname As String, ky As String, n As String Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then WSname = Sh.Name: ky = Replace(WSname, "ال", "") For iRow = 7 To WS.Range("R" & WS.Rows.Count).End(xlUp).Row n = WS.Cells(iRow, "R").Value If InStr(1, n, ky, vbTextCompare) > 0 And n <> "" Then tmp = WS.Cells(iRow, "E").Value j = False For Each cell In Sh.Range("E7:E" & Sh.Rows.Count) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = WS.Range(WS.Cells(iRow, 2), WS.Cells(iRow, 28)) dstRng = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 Sh.Cells(dstRng, "B").Resize(, 27).Value = Rng.Value Sh.Cells(dstRng, "D").Value = Date lastRow = Sh.Cells(Sh.Rows.Count, "B").End(xlUp).Row Sh.Cells(lastRow, "B").Formula = Cnt Updated = True End If End If Next iRow End If Next Sh MsgBox IIf(Updated, "تم ترحيل البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub ترحيل الصفوف مع عدم التكرار بتحقق شرط v2.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Const Main As String = "الرئيسية " Sub destination(WSname As String) Dim WS As Worksheet, f As Worksheet, srcWS As Worksheet Set srcWS = Sheets(Main) Application.ScreenUpdating = False For Each WS In ThisWorkbook.Worksheets If WS.Name = WSname Then Set f = WS Exit For End If Next WS On Error Resume Next For Each WS In ThisWorkbook.Worksheets If WS.Name <> WSname Then WS.Visible = xlSheetVeryHidden Next WS On Error GoTo 0 f.Visible = xlSheetVisible: f.Activate If srcWS.Visible = xlSheetVisible And WSname <> Main Then srcWS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True End Sub Sub GoToMainSheet() Sheets(Main).Visible = xlSheetVisible destination Main End Sub Sub GoToPage1() destination "كشف التلامي الحاضرين صفحة 1" End Sub Sub GoToPage2() destination "كشف التلامي الحاضرين صفحة 2" End Sub Sub GoToPage3() destination "الدخول و الخروج خلال الشهر" End Sub Sub GoToPage4() destination "المعلومات العامة" End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Dim WS As Worksheet Const srcWS As String = "الرئيسية " For Each WS In ThisWorkbook.Worksheets WS.Visible = IIf(WS.Name = srcWS, xlSheetVisible, xlSheetHidden) Next WS End Sub كشف التلاميذ الحاضرين 2023--2024.xlsb

اخي هدا ما يفعله الكود فعلا بعد تعديلك للسطر المشار إليه LastRow = 45 اي عدد الصفوف لديك على الملف او تثبيتها هنا مباشرة WS.Range(WS.Cells(4, tmp), WS.Cells(45, tmp)).Interior.Color = RGB(255, 255, 0) جدول الحصص الإضافية 3.xlsb

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

لقد تم فعلا وضع الإختيار في الكود المقترح سابقا ربما لم تنتبه لهدا في حالتك يكفي البقاء على Dim LastRow As Long LastRow = 45

وعليكم السلام ورحمة الله تعالى وبركاته كما سبق الدكر من الأستاد @عبدالله بشير عبدالله طلبك غير واضح إظافة أن أرقام الأعمدة على الملف تتواجد في الصف 3 ليس 2 مجرد تخمين ربما تقصد جلب بيانات العمود بشرط إدخال قيمة رؤوس الأعمدة (رقم العمود) جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Variant, tmp As Variant, lastRow As Long, a As Long, Clé As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, WS.Range("AQ3:BO3")) Is Nothing Then lastRow = WS.Columns("A:Z").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row OnRng = WS.Range("A4:Z" & lastRow).Value tmp = WS.Range("A3:Z3").Value Clé = Target.Value Application.ScreenUpdating = False If IsEmpty(Target.Value) Then WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)).ClearContents Else For a = 1 To UBound(tmp, 2) If tmp(1, a) = Clé Then With WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)) .ClearContents .Value = Application.Index(OnRng, 0, a) End With Exit For End If Next a End If If a > UBound(tmp, 2) Then Target.ClearContents: MsgBox "لم يتم العثور على " & _ Target.Value & " في قاعدة البيانات", vbExclamation, "إنتبـــاه" End If Application.ScreenUpdating = True End Sub استخراج الاعمدة.xlsm

المعادلة ليس بها أي خطأ أخي @محمد زيدان2024 ربما قمت بوضعها بشكل غير صحيح معادلة ترقيم.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك إختيار ما يناسبك Sub CopyRowsmaktab() Dim LR As Long, I As Long, X As Long LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Sheets("دريم").Range("B6:G" & Sheets("دريم").Rows.Count).ClearContents For I = 6 To LR If Sheets("Main").Cells(I, "B").Value = "دريم" Then Sheets("دريم").Range("B" & X & ":G" & X).Value = Sheets("Main").Range("B" & I & ":G" & I).Value X = X + 1 End If Next I Application.ScreenUpdating = True End Sub او Sub CopyRowsToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim WSRng As Range, destRng As Range, Criteria As String Set WS = Sheets("Main") Set dest = Sheets("دريم") Criteria = "دريم" LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = Criteria Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub او Sub CopiesToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim Ky As Boolean, WSRng As Range, destRng As Range Set WS = Sheets("Main") Set dest = Sheets("دريم") LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Ky = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Ky = True Exit For End If Next n If Not Ky Then MsgBox "لا يوجد بيانات مطابقة للنسخ", vbExclamation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

تم تعديل المشاركة السابقة لتتناسب مع طلبك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub Worksheet_Change(ByVal Target As Range) Dim srcWS As Worksheet, début As Long, Fin As Long Dim a As Variant, b As Variant, i As Long Set srcWS = Me a = srcWS.[B3].Value b = srcWS.[C3].Value If Not Intersect(Target, srcWS.Range("B3:C3")) Is Nothing Then If a = "" Or b = "" Then Exit Sub If IsNumeric(a) And IsNumeric(b) Then début = a Fin = b If début <= Fin Then srcWS.Range("F7:F" & srcWS.Rows.Count).ClearContents For i = début To Fin srcWS.Cells(6 + i - début + 1, "F").Value = i Next i Else MsgBox _ " بداية الترقيم يجب أن تكون أصغر أو تساوي نهاية الترقيم", vbExclamation, "خطأ في الإدخال" End If End If End If End Sub بالمعادلات =IF(ROW(F7)-ROW($F$7)+$B$3<=$C$3, ROW(F7)-ROW($F$7)+$B$3, "") ترقيم.xlsb

Sub Remplissez_jours_dates() Dim début As Date, DateFin As Date, CrDate As Date Dim tmp As Long, DayArr As Variant, i As Long Dim WS As Worksheet: Set WS = Sheets("البنين") If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _ Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Or _ WS.Range("K2").Value > WS.Range("O2").Value Then MsgBox "يرجى التأكد من صحة التواريخ " & vbCrLf & _ "وتاريخ البدء لا يكون أكبر من تاريخ الانتهاء", vbExclamation Exit Sub End If début = WS.Range("K2").Value DateFin = WS.Range("O2").Value ' لاخر اسم في عمود b Dim LastRow As Long LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row 'لاخر الكشف الصف 45 ' LastRow = 45 Application.ScreenUpdating = False WS.Range("D4:AH5").ClearContents With WS.Range("D4:AH45") .Interior.Pattern = xlNone .Font.Color = RGB(0, 0, 0) End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Range(WS.Cells(4, tmp), WS.Cells(LastRow, tmp)).Interior.Color = RGB(255, 255, 0) WS.Range(WS.Cells(4, tmp), WS.Cells(5, tmp)).Font.Color = RGB(255, 0, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True End Sub جدول الحصص الإضافية 2.xlsb

début = WS.Range("K2").Value DateFin = WS.Range("O2").Value Set Rng = WS.Range("D4:AH5") If début > DateFin Then : MsgBox "لا يمكن أن يكون تاريخ البدء أكبر من تاريخ الانتهاء", vbExclamation :Exit Sub Application.ScreenUpdating = False With Rng .ClearContents .Interior.ColorIndex = xlNone End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Cells(4, tmp).Interior.Color = RGB(255, 255, 0) WS.Cells(5, tmp).Interior.Color = RGB(255, 255, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True جدول الحصص الإضافية.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا Sub Remplissez_jours_dates() Dim début As Date, DateFin As Date, CrDate As Date Dim tmp As Long, DayArr As Variant Dim WS As Worksheet: Set WS = Sheets("البنين") If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _ Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Then MsgBox "يرجى التأكد من صحة التواريخ ", vbExclamation Exit Sub End If début = WS.Range("K2").Value DateFin = WS.Range("O2").Value If début > DateFin Then: MsgBox "لا يمكن أن يكون تاريخ البدءأكبر من تاريخ الانتهاء", vbExclamation: Exit Sub Application.ScreenUpdating = False WS.Range("E4:AH5").ClearContents DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") tmp = 4 CrDate = début Do While CrDate <= DateFin If Weekday(CrDate, vbSunday) <> 6 And Weekday(CrDate, vbSunday) <> 7 Then If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate tmp = tmp + 1 End If CrDate = CrDate + 1 Loop Application.ScreenUpdating = True End Sub وفي حدث ورقة البنين Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("K2,O2")) Is Nothing Then Remplissez_jours_dates End If End Sub جدول الحصص الإضافية.xlsb

جرب هدا Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range Dim choose As VbMsgBoxResult, DataRng As Range, Cnt As Boolean Set WS = Sheets("ورقة1") Set DataRng = WS.Range("A1:E50") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Cnt = False For i = 3 To lastRow If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then Cnt = True Exit For End If Next i If Not Cnt Then MsgBox "لا توجد بيانات مطابقة للحذف", vbExclamation, "خطأ" Exit Sub End If choose = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") Application.ScreenUpdating = False If choose = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If Next i If Not OnRng Is Nothing Then OnRng.Delete For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i MsgBox "تم حذف الصفوف بنجاح", vbInformation, "الحذف" With WS .PageSetup.TopMargin = .PageSetup.BottomMargin = .PageSetup.LeftMargin = .PageSetup.RightMargin = Application.InchesToPoints(0.5) .[C1].Value = Format(Date - 1, "dd/mm/yyyy") .[B1].Value = Format(Date - 1, "dddd") End With With DataRng.Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" End If Application.ScreenUpdating = True End Sub مثال1 v2.xlsm

DC.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته الإسم المفروض وضع الصيغة التالية في عمود الاسم لاكنها ستقوم باستخراج الأسماء مكررة بعدد تواجدها في عمود الإسم لهدا قم بوضعها مثلا في الخلية Q6 وسحبها للأسفل =IFERROR(INDEX(D$6:D$139,SMALL(IF($H$6=$C$6:$C$139,ROW($D$6:$D$139)-5),ROW(J1))),"") ثم وضع المعادلة التالية في الخلية K6 مع سحبها للأسفل لإستخراج الأسماء بدون تكرار =IFERROR(IF(Q6<>"", INDEX($Q$6:$Q$139, MATCH(0, COUNTIF($K$5:K5, $Q$6:$Q$139) + IF($Q$6:$Q$139="", 1, 0), 0)), ""), "") إجمالي الإسم =IF(K6<>"",SUMIF($D$6:$D$139, K6, $E$6:$E$139),"") إجمالي البيان =SUMIF(C6:C139, H6, E6:E139)

اعتقد أن النتائج على الصورة الخاصة بك غير صحيحة أم أنا قد فهمت طلبك بشكل خاطئ جرب هدا =IF($H$5303<>"", COUNTIFS($D$2:$D$5294, $H$5303, $I$2:$I$5294, G5306), "") او =IF($H$5303<>"", IF(COUNTIFS($D$2:$D$5294, $H$5303, $I$2:$I$5294, G5306) > 0, COUNTIFS($D$2:$D$5294, $H$5303, $I$2:$I$5294, G5306), "لا توجد طلبات"), "") احصاء عدد الطلبات.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب إحدى المعادلات التالية =IF(D5304<>"",COUNTIFS(D2:D5294, D5304),"") أو =IF(D5304<>"",COUNTIF($D$2:$D$5294, D5304), "") ولجلب Driver ID =IFERROR(INDEX($D$2:$D$5294, MATCH(0, IF(($D$2:$D$5294<>"")* ($D$2:$D$5294<>0), COUNTIF($D$5303:D5303, $D$2:$D$5294), ""), 0)), "") احصاء عدد الطلبات.rar

وعليكم السلام ورحمة الله تعالى وبركاته ممكن توضح لنا ما المانع من إظافة عمود التسلسل يدويا وإعادة تعديل الكود بما يتناسب مع شكل البيانات ؟ اذا كان هذا يناسبك إليك الكود المعدل Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range, response As VbMsgBoxResult Set WS = Sheets("ورقة1") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If End If Next i If Not OnRng Is Nothing Then OnRng.Delete MsgBox OnRng.Count & " تم حذف الصفوف بنجاح", vbInformation, "عملية الحذف" Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" Exit Sub End If With WS.Range("A1:E50").Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i With WS.PageSetup .TopMargin = .BottomMargin = .LeftMargin = .RightMargin = Application.InchesToPoints(0.5) End With WS.[C1].Value = Date - 1: WS.[C1].NumberFormat = "dd/mm/yyyy" WS.[B1].Value = Format(Date - 1, "dddd") Application.ScreenUpdating = True End Sub مثال1.xlsm

اخي @أبوالباسل دالة VLOOKUP لديها قاعدة أساسية يجب الإنتباه إليها فهي تعمل فقط من اليسار إلى اليمين بمعنى تبحث دائما في العمود الأول من النطاق المحدد وهو في حالتك العمود G لكنك تريد البحث عن رقم سير باستخدام العمود H (الذي يحتوي على أسماء العملاء) وهذا يخالف طريقة عمل VLOOKUP لأن العمود H ليس العمود الأول بإختصار دالة VLOOKUP لا يمكنها البحث في عمود ليس هو الأول ضمن نطاق البيانات لهدا حاولنا إستخدام بدائل أخرى مثل INDEX و MATCH هذه الدوال لا تعتمد على ترتيب الأعمدة للتوضيح أكثر حاول عكس ترتيب الأعمدة بجعل عمود أسماء العملاء على اليمين وجعل عمود سير يسارا ووضع المعادلة الخاصة بك على الشكل التالي =IF(C3<>"", IFERROR(VLOOKUP(C3, $G$3:$H$121, 2, 0), "غير موجود"), "") كما تلاحظ VLOOKUP الآن تبحث في العمود H (أسماء العملاء) لأنه أصبح العمود الأول و تسترجع القيمة المقابلة من العمود G (سير ) بنجاح خط السير-VLOOKUP.xlsx

تفضل أخي تم تعديل الكود السابق وإظافة إمكانية تحديد الأعمدة المرحلة والمرحل إليها لتتمكن من تعديله بما يناسبك لاحقا Option Explicit Dim tmp As Variant Const tmpCol As String = "G" Private Sub Worksheet_Change(ByVal Target As Range) Dim arr(3) As Worksheet, OnRng As Range, Irow As Long, ling As Variant Set arr(0) = Sheets("بطاقة صنف"): Set arr(1) = Sheets("اضافة") Set arr(2) = Sheets("الصرف"): Set arr(3) = Sheets("الأصناف") If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then SetApp False Set OnRng = arr(0).Range("B6:I" & arr(0).Rows.Count) OnRng.ClearContents Irow = arr(3).Cells(arr(3).Rows.Count, 1).End(xlUp).Row Me.Range("I3").Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & Irow & ",2,0),"""")" Me.Range("I3").Value = Me.Range("I3").Value ling = Me.Range("I3").Value If Not IsEmpty(ling) And ling <> "" Then tmp = ling Call Cnt(arr(1), arr(0), ling, Array(4, 9, 10, 14, 16), Array(3, 5, 6, 4, 2)) Call Cnt(arr(2), arr(0), ling, Array(4, 19, 17, 9, 10, 11), Array(3, 2, 4, 7, 8, 9)) Else OnRng.ClearContents GoTo AppTrue End If AppTrue: SetApp True End If End Sub '"""""""""""""""""""""""""""""""""""" Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _ ByVal temp As Variant, ByVal Colky As Variant, ByVal DestCols As Variant) Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range, début As Long, fin As Long LastRow = dest.Cells(dest.Rows.Count, tmpCol).End(xlUp).Row début = 3 fin = LastRow For i = début To fin With dest If Not IsEmpty(.Cells(i, tmpCol).Value) And Not IsError(.Cells(i, tmpCol).Value) Then If .Cells(i, tmpCol).Value = temp Then x = WorksheetFunction.CountA(tbl.Range("B6:B1000")) For n = LBound(Colky) To UBound(Colky) Set Cel = tbl.Cells(6 + x, DestCols(n)) Cel.Value = .Cells(i, Colky(n)).Value Next n End If End If End With Next i End Sub '""""""""""""""""""""""""""""" Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مخازن 2024مكرو v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب إستخدام إحدى الصيغ التالية =IFERROR(INDEX($G$3:$G$121, MATCH(C3, $H$3:$H$121, 0)), "غير موجود") 'أو =XLOOKUP(C3, $H$3:$H$121, $G$3:$G$121, "غير موجود") بالأكواد Option Explicit Sub UpdateOrder() Dim WS As Worksheet, lastRow As Long, i As Long Dim Client As String, tmp As Variant Set WS = Sheets("خط السير") lastRow = 120 Application.ScreenUpdating = False WS.Range("b3:b" & lastRow).ClearContents For i = 3 To lastRow Client = WS.Cells(i, "C").Value If Client <> "" Then tmp = Application.Match(Client, WS.Range("H3:H" & lastRow), 0) If Not IsError(tmp) Then WS.Cells(i, "B").Value = WS.Cells(tmp + 2, "G").Value Else WS.Cells(i, "B").Value = "غير موجود" End If End If Next i Application.ScreenUpdating = True End Sub خط السير.rar

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Sub TaxCivil() Dim Irow&, lastRow&, lastCol&, i&, j&, k&, WS As Worksheet, dest As Worksheet, tmp As Double, _ OnRng As Variant, r As Variant, headers As Variant, n As Double, civil As String Set WS = Sheets("المعلومات") Set dest = Sheets("الموظفين") Application.ScreenUpdating = False Irow = dest.Cells(dest.Rows.Count, 3).End(xlUp).Row lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row lastCol = WS.Cells(2, WS.Columns.Count).End(xlToLeft).Column OnRng = dest.Range("A2:E" & Irow).Value r = WS.Range(WS.Cells(3, 1), WS.Cells(lastRow, lastCol)).Value headers = WS.Range(WS.Cells(2, 3), WS.Cells(2, lastCol)).Value dest.Range("E2:E" & Irow).ClearContents For i = 1 To UBound(OnRng, 1) n = OnRng(i, 3): civil = OnRng(i, 4) tmp = 0 If n = 0 Or Trim(civil) = "" Then GoTo SkipRow For j = 1 To UBound(r, 1) If n >= r(j, 1) And n <= r(j, 2) Then For k = 1 To UBound(headers, 2) If headers(1, k) = civil Then tmp = r(j, k + 2) Exit For End If Next k Exit For End If Next j OnRng(i, 5) = IIf(tmp > 0, tmp, "غير محدد") SkipRow: Next i dest.Range("A2").Resize(UBound(OnRng, 1), 5).Value = OnRng Application.ScreenUpdating = True End Sub ضريبة.xlsb

اخي لقد تم الاعتماد على الأعمدة المحددة في الكود الخاص بك Call Cnt(Sh1, WS, ling, Array(16, 4, 14, 9, 10)) Call Cnt(Sh2, WS, ling, Array(19, 4, 17, 9, 10, 11)) على العموم بعد تعديلها بما جاء في اخر مشاركة لك هده هي نتيجة كارت الصنف 121 لاحظ الصورة المرفقة ادا كان هدا هو المطلوب اخبرني بدالك