محمد هشام.

نعم أخي يمكنك تعديل السطور الأخيرة من الكود 
Dim fichier As String ' قم بتحديد خلية الإسم بما يناسبك fichier = WS.Range("E30").Value filePath = pdfFolder & "\" & fichier & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me وبما أن ورقة Round 5  تتضمن إسم المستفيد على عمود c يمكنك استخدام هدا ليتم تسمية الملف ديناميكيا عند التنفيد مع مزيدا من التحقق 
Private Sub CommandButton2_Click() Dim r As Long, s As Long, t As Long, FolderName As String, pdfFolder As String, i As Integer Dim filePath As String, ID As String, Item As String, tmp As String, Chars As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) For r = s To t If Trim(dest.Range("B" & r + 2).Value) <> "" Then Exit For Next r If r > t Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات", vbExclamation: Exit Sub pdfFolder = ThisWorkbook.Path & "\الإيصالات" If Dir(pdfFolder, vbDirectory) = "" Then MkDir pdfFolder Chars = "\ / : * ? "" < > |" For r = s To t ID = Trim(dest.Range("B" & r + 2).Value) '(C)'جلب إسم المستفيد من عمود Item = Trim(dest.Range("C" & r + 2).Value) '(ID)' تجاهل حفظ الملف عند التحقق من عدم وجود إسم المستفيد أو رقم If ID = "" Or Item = "" Then GoTo Cnt tmp = Item For i = 1 To Len(Chars) tmp = Replace(tmp, Mid(Chars, i, 1), "") Next i filePath = pdfFolder & "\" & tmp & ".pdf" WS.[d4] = ID: WS.[U2] = ID On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Cnt: Next r MsgBox ": تم تصدير الملفات إلى مجلد" & pdfFolder, vbInformation Unload Me End Sub  
PTT 2024 v3.xlsm

إليك الكود بعد تعديله 
Public Sub FilterAndCopy() Const tmpCol As String = "BC" Dim OnRng As Range, i As Long, n As Long, r As Long Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet Set WS = Sheets("اجمالي4") Set Sh1 = Sheets("بنون ناجحون") Set Sh2 = Sheets("بنات ناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A5:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With n = 7: r = 7 For i = 1 To OnRng.Rows.Count + 1 If InStr(1, WS.Cells(i, tmpCol).Value, "ناجح", vbTextCompare) > 0 Then If WS.Cells(i, 9).Value = "ذكر" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh1.Range("A" & n) n = n + 1 ElseIf WS.Cells(i, 9).Value = "انثى" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh2.Range("A" & r) r = r + 1 End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub  
 
ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

جرب هدا بعد تنفيد ما سبق دكره سابقا 
Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub  
المصنف 4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
دالة IF تحتاج إلى شروط واضحة وتنتظر تحديد ما يجب أن يتم في حال كان الشرط صحيحا أو خطأفي حالتك IF "" غير مكتمل لأنك لم تحدد ما يجب تنفيذه في حال كانت الشروط فارغة أو صحيحة
إذا كنت تحاول استخدام دالة IF مع FILTER لتحديد قيمة فارغة مثلا  عند عدم وجود نتائج في FILTER فيمكنك استخدام دالة IFERROR 
=IFERROR(FILTER(AP4:AT353, ISNUMBER(SEARCH(AF6, AQ4:AQ353))), "") مع التأكد من أن الفواصل في الصيغة تتناسب مع الاصدار الموجود لديك  ;  او ,

وعليكم السلام ورحمة الله تعالى وبركاته 
ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض 
ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب 
في  Module1 ضع الأكواد التالية
Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية 
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع
Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج 
Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF
Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............
 
 
جرد المنتج_V2.xlsb

ولا يهمك أخي @محمد العراقى   سنكون سعداء دائما بحصولك على النتائج المطلوبة 

يكفي تعديل هدا الجزء من الكود 
For j = LBound(DaysArr) To UBound(DaysArr) For i = 0 To 7 ' الحصص dest.Cells(Irow, i + 2).Value = WS.Cells(OnRng.Row, cnt + i).Value ' المواد If WS.Cells(OnRng.Row + 1, cnt + i).Value <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row + 1, cnt + i).Value End If Next i cnt = cnt + 8 Irow = Irow + 2 Next j  
اجر-V2.xls

يمكنك دمج الطريقتين مع بعض كما في الصورة 

 
ListBox1.ColumnCount = 12-V3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله 
Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub  لقد لاحظت وجود أسماء رقمية في عمود المركز

' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then  
ترحيل 1 الى شيتات منفصلة v1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
Option Explicit Private Sub CommandButton1_Click() Dim MinDate As Date, MaxDate As Date Dim WS As Worksheet, dest As Worksheet Dim a As Variant, tmp As String Dim dc As Object, dnc As Object, dnc1 As Object Dim arr() As Variant, n As Long, lastRow As Long, i As Long Dim Rng As Range, C As Range, col As Variant, key As Variant Set WS = Sheets("DATA"): Set dest = Sheets("Report") If Not IsDate(TextBox1.Value) Or Not IsDate(TextBox2.Value) Then MsgBox "المرجوا التحقق من التواريخ", vbExclamation Exit Sub End If MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6): dc(tmp) = a(i, 8): dnc(tmp) = a(i, 9) Else dc(tmp) = dc(tmp) + a(i, 8): dnc(tmp) = dnc(tmp) + a(i, 9) End If End If Next i If dc.Count > 0 Then Application.ScreenUpdating = False With dest.Range("C12:F" & dest.Rows.Count) .ClearContents: .ClearFormats End With n = 1 ReDim arr(1 To dc.Count, 1 To 4) For Each key In dc.Keys arr(n, 1) = dnc1(key): arr(n, 2) = key: arr(n, 3) = dc(key): arr(n, 4) = dnc(key) n = n + 1 Next key dest.Range("C12").Resize(dc.Count, 4).Value = arr lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row dest.Cells(lastRow + 1, "D").Value = "الإجمالي" For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col dest.Range("E9").Value = MinDate: dest.Range("F9").Value = MaxDate Set Rng = dest.Range("C12:F" & lastRow) For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C Else MsgBox "لا توجد بيانات تطابق التواريخ المحددة" End If Application.ScreenUpdating = True End Sub  
 
TEST v1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub  
 
 
غلق المدى المحدد .xlsb

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 Dim Hrd As String 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 Hrd = WS.Cells(3, cell.Column).Value kay = Hrd 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  
New V2.xlsb

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

 
 
Book2 v2.xlsm

لا أعلم ما تحاول فعله لاكن جرب وضع  الكود التالي في Module
Public Sub RunCode() Dim WS As Worksheet, dest As Worksheet Dim tmp As Double, cell As Range Set WS = ThisWorkbook.Sheets("الادخال") Set dest = ThisWorkbook.Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then On Error Resume Next Set cell = dest.Range("A2:A" & _ dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole) On Error GoTo 0 If Not cell Is Nothing Then cell.Offset(0, 19).Value = Date End If End If End Sub  وفي حدث ThisWorkbook 
Private Sub Workbook_Open() Application.OnKey "{F10}", "RunCode" End Sub '==================== Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F10}" End Sub بهذه الطريقة بعد إظافة رقم الإدخال يمكنك تشغيل الكود باستخدام زر F10 فقط  من لوحة المفاتيح  (يمكنك تعيدله بما يناسبك ) ولا يستجيب أثناء التنقل أو تحديد خلايا أخرى 
2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
بما أنك تستخدم الأكواد على الملف أعتقد أنه بإمكانك ربط الكود بأي شكل وتقوم بوضعه فوق الصورة عادي
نفس الفكرة المقترحة من الأخ @أبومروان  بواسطة الأكواد مع إمكانية تحديد إسم الصورة والتعليق المرغوب إظهاره .يمكنك إظافة أي عدد من الأشكال وتعديل النطاقات بما يتناسب مع إحتياجاتك 

 
 
 
wor-v2.xlsm

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

Private Sub SearchData() Dim fnd As Range Dim ColA As String, ColB As String, ColC As String Dim criteria As Range, found As Boolean Dim rowNum As Long ColA = Me.ComboBox1.Value ColB = Me.ComboBox2.Value ColC = Me.ComboBox3.Value If Len(ColA) = 0 Then Exit Sub Set criteria = WS.Range("A4:C" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) found = False For Each fnd In criteria.Rows If fnd.Cells(1, 1).Value = ColA And _ (ColB = "" Or Format(fnd.Cells(1, 2).Value, "dd-mmm") = ColB) And _ (ColC = "" Or fnd.Cells(1, 3).Value = ColC) Then For i = 1 To 62 Me.Controls("TextBox" & i).Value = fnd.Cells(1, i).Value Next i rowNum = fnd.Row found = True Exit For End If Next fnd If Not found Then ClearTextBoxes Me.Line.Value = "" Else Me.Line.Value = rowNum End If End Sub  
 
Private Sub CommandButton2_Click() Dim r As Integer, n As Variant Dim i As Integer, X As Integer Dim rowNum As Long, fnd As Range If IsNumeric(Me.Line.Value) Then rowNum = CLng(Me.Line.Value) Else MsgBox " يرجى تحديدالبيانات المرغوب تعديلها", vbExclamation Exit Sub End If If rowNum < 5 Then: Exit Sub If SaisieText(1, 2) Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد") If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Cells(rowNum, 1) For i = 1 To 62 On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 If IsDate(n) Then fnd.Offset(0, i - 1).Value = CDate(n) Else fnd.Offset(0, i - 1).Value = n End If Next i Call UpdateNum(WS) Clear_TextBox UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم التعديل بنجاح", vbInformation End Sub    
Private Function SaisieText(startIdx As Integer, endIdx As Integer) As Boolean Dim i As Integer, X As Integer Dim arr() As String, TexArr As String For i = startIdx To endIdx If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(X) arr(X) = TexArr X = X + 1 End If Next i If X > 0 Then MsgBox ": يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation SaisieText = True Else SaisieText = False End If End Function  
ترحيل مع كمبوبوكس البحث بحقلين V3.xlsm

Book1.xlsb

ضع الأكواد التالية  في حدث ورقة 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

ربما هدا ما تقصده 

 
 
تعديل فورم V6 -.rar

تفضل أخي  @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

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
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  

هل تقصد ان جدول البيانات 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

وعليكم السلام ورحمة الله تعالى وبركاته 
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

اخي @mahmoud nasr alhasany
 خاصية ColumnHeads = True في عنصر التحكم ListBox لا تعمل إلا إذا كانت البيانات مرتبطة مباشرة بنطاق خلايا من ورقة العمل باستخدام خاصية RowSource
عندما تستخدم الطريقة AddItem لإضافة البيانات يدويا لن يتم عرض رؤوس الأعمدة  حتى لو قمت بتعيين ColumnHeads = True
حاول إضافة رؤوس الأعمدة باستخدام عناصر Label بدلا من الاعتماد على رؤوس الأعمدة داخل الـ ListBox 
يمكنك تحديدها داخل كود تهيئة اليوزرفورم بعد اظافة عناصر label جديدة بعدد العناوين المرغوب عرضها وتسميتها بإسم مختلف لكي لا يتعارض الكود مع العناصر السابقة
مثلا (hrd1- hrd2-...-hrd6)
 
Private Sub UserForm_Initialize() 'الكود الخاص بك Dim arr As Variant arr = Array("كود", "صنف", "سعر", "كمية المخزون", "اسم المخزن", "تاريخ نهاية الصنف") For i = 1 To 6 Me("hrd" & i).Caption = arr(i - 1) Next i End Sub
وتعديل الكود على   Private Sub CommandButton1_Click()
With ListBox2 .Clear .ColumnCount = 6 .ColumnWidths = colWidths .Font.Size = 10 End With currentRow = 0 For i = 2 To lastRow If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" Then ListBox2.AddItem ListBox2.List(currentRow, 0) = ws.Cells(i, 1).Value ' كود ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ' صنف ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ' سعر ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ' كمية المخزون ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ' اسم المخزن ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value ' تاريخ نهاية الصنف currentRow = currentRow + 1 End If Next i  
عملية بحث بشرطين او اكثر.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
Option Explicit Private Sub TextBox1_Change() Dim WS As Worksheet: Set WS = ActiveSheet Dim LastRow As Long, OnRng As Range LastRow = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row Set OnRng = WS.Range("A2:AE" & LastRow) If Me.TextBox1.Value = "" Then If WS.AutoFilterMode Then WS.AutoFilterMode = False End If Else OnRng.AutoFilter Field:=3, _ Criteria1:=Me.TextBox1.Value & "*", Operator:=xlOr, Criteria2:=Me.TextBox1.Value End If End Sub