محمد هشام.

بكل سرور اخي @Alaa Ammar New يسعدنا اننا استطعنا مساعدتك

لم تدكر اخي ما هو النطاق المطلوب تفضل جرب هل هدا ما تقصده Sub CopySheet() Dim filePath$, folderName$, Fname$ Dim rCopy As Range, rng As Range Dim lRow As Long, i As Integer Dim wbSource As Workbook Set wbSource = ThisWorkbook Set WS = wbSource.Worksheets("Sheet1") lRow = WS.Range("B" & WS.Rows.Count).End(xlUp).Row Set rCopy = WS.Range("A7:K" & lRow).SpecialCells(xlCellTypeVisible) folderName = "ملفات Excel" Fname = "تقرير النشاط" filePath = ThisWorkbook.path & "\" & folderName On Error Resume Next 'OR 'filePath = "D:" & "\" & folderName If WS.Range("L9:L" & lRow).SpecialCells(xlCellTypeVisible).Count > 1 Then With Application .ScreenUpdating = False .DisplayAlerts = False .CopyObjectsWithCells = False Set newWb = Workbooks.Add: Set SH = newWb.Sheets(1) rCopy.Copy Destination:=SH.Range("A3") LastR = SH.Range("A" & SH.Rows.Count).End(xlUp).Row SH.Range("A7:A" & LastR).RowHeight = 28 For i = 1 To 11 Columns(i).ColumnWidth = WS.Columns(i).ColumnWidth Next i SH.[A5] = 1: SH.Range("A5:A" & SH.Cells(Rows.Count, 2).End(3).Row).DataSeries , xlLinear 'Columns(1).Delete If Dir(filePath, vbDirectory) = "" Then MkDir filePath newWb.SaveAs fileName:=filePath & "\" & Fname & ".xlsx", FileFormat:=51 newWb.Close .CopyObjectsWithCells = True .DisplayAlerts = True .ScreenUpdating = True End With sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & WS.[D4] & " " & "إلى تاريخ:" & " " & WS.[F4] Else MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء" End If End Sub فلترة وحفظ.xlsm

اسف اخي لم انتبه فعلا على العموم حل الاستاد حسونة سوف يلبي المطلوب بالتوفيق.

تقصد ان هدا الشكل لا يناسبك هل قمت بتجربة هدا Sub test() Dim lCol As Long, MyRng As Range Set desWS = ActiveSheet: Set ws = Sheet2 If Len(desWS.[CA328].Value) = 0 Then Exit Sub ws.Cells.Clear For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i Set MyRng = desWS.[BW330:CK372] Application.ScreenUpdating = False MyRng.Copy If ws.[D9] = "" Then MyRng.Copy With ws.[c5] .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats End With Else lCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column + 5 MyRng.Copy With ws.Cells(5, lCol) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats End With End If Application.CutCopyMode = False Application.ScreenUpdating = True Next i End Sub 2024-04-11 الفواتير من 2024-04-05 الى.pdf

ربما لو قمت بارفاق الملف سوف تكون الامور اوضح تفضل جرب Sub General() Dim LatR As Long: Dim sFile As String Set WS = ActiveSheet: sFile = [F3].Value On Error Resume Next LatR = Range("A:A").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With WS .PageSetup.PrintArea = Range("A2:AF" & LatR).Rows.SpecialCells(xlCellTypeVisible).Address .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 sNewFilePath = ThisWorkbook.Path & "\" .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=sNewFilePath & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Sheets("النتيجة2").Select End Sub TEST PDF.xlsb

جرب هدا Dim sFile As String sFile = Range("F3").Value sNewFilePath = ThisWorkbook.Path & "\" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=sNewFilePath & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False مجرد تخمين ربما يفيدك Sub General() Dim LatR As Long: Dim sFile As String Set WS = ActiveSheet: sFile = [F3].Value LatR = Range("a:a").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row WS.PageSetup.PrintArea = Range("A2:AF" & LatR).Rows.SpecialCells(xlCellTypeVisible).Address WS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 sNewFilePath = ThisWorkbook.Path & "\" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=sNewFilePath & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Sheets("النتيجة2").Select End Sub

ادا كنت قد فهمت طلبك بشكل صحيح يمكنك الحصول على دالك بتفعيل هدا السطر حيث يتم فلترة البيانات بشرط عمود المفتاح ما بين التواريخ الموجودة في الخلايا D4 و F4 '******* اظافة شرط بين تاريخين rng.AutoFilter field:=3, _ Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _ Criteria2:="<=" & CDbl(WS.[F4]) اما بالنسبة ل كود عمل نسخة احتياطية كل عشر دقائق ضع الكود التالي في module Sub SaveBackup() Dim filePath$,folderName$,copyName$ Dim ThisBook As Workbook : Set ThisBook = ThisWorkbook 'مسارالحفظ ' filePath = "D:": 'اسم مجلد الحفظ folderName = "BACKUPS" With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next copyName = filePath & "\" & folderName & " " & _ Format(Now, "dd-mmmm-yyyy") 'انشاء مجلد الحفظ في حالة عدم العثور عليه If Dir(copyName, vbDirectory) = "" Then MkDir copyName ThisBook.SaveCopyAs copyName & "\" & ThisBook.Name & " " & _ Format(Now, "dd-mmmm-yyyy-HH-MM-SS") & ".xlsm" ' قم بتعديل وقت الحفظ بما يناسبك Application.OnTime Now + TimeValue("00:10:00"), "SaveBackup" 'حفظ المصنف الرئيسي ' ActiveWorkbook.Save .DisplayAlerts = True .ScreenUpdating = True End With End Sub وفي حدث Private Sub Workbook_Open Private Sub Workbook_Open() Call SaveBackup End Sub تفضل جرب المرفق التالي بالتوفيق فلترة وحفظ.xlsm

جرب هدا Private Sub TextBox1_Change() Set WS = Sheets("Sheet1") On Error Resume Next If WS.TextBox1.Text = Empty Then WS.[A8:L8].AutoFilter lr = WS.Cells(WS.Rows.Count, "L").End(xlUp).Row Clé = "*" & Replace(WS.TextBox1.Text, " ", "*") & "*" If WS.TextBox1.Text <> "" Then Set rng = WS.Range("A8:L" & lr) '****المفتاح***** rng.AutoFilter field:=12, Criteria1:=Clé '******* اظافة شرط بين تاريخين rng.AutoFilter field:=3, _ Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _ Criteria2:="<=" & CDbl(WS.[F4]) Else WS.[A8:L8].AutoFilter End If End Sub Sub test() Dim desWS As Worksheet: Set desWS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = printing Application.ScreenUpdating = False If Sheets("Sheet1").TextBox1.Text = "" Then Exit Sub rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000")) If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub Set a = desWS.Range("A8", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) ' For r = 1 To 11 لغاية عمود الملاحظات For r = 1 To 12 'مفتاح ' لغاية عمود Set a = Union(a, Intersect(a.EntireRow, a.Columns(r))) Next r Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name) If Msg <> vbYes Then Exit Sub dest.Range("A3:L" & dest.Rows.Count).Clear a.Copy Destination:=dest.Range("A6") 'حفظ PDF Save_As_PDF2 On Error Resume Next desWS.AutoFilter = False Sheets("Sheet1").TextBox1.Text = "" Application.ScreenUpdating = True End Sub فلترة وحفظ PDF +EXCEL V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب هدا (تم اظافة ورقة جديدة مخفية على الملف باسم PDF لتجميع الفواتير اظن ان مدى بيانات الفاتورة غير مطابق لما كتبته هنا ادا لم اكن مخطئ Sub svPDF() Dim MyRng As Range, r As Long, i As Integer, LR As Long Dim fRow, Cpt As Range, FndRng As Range, myValue As String Dim sFile As String, FolderName As String Set desWS = Sheet79: Set WS = PDF Set MyRng = desWS.[BW330:CK372] minDate = Format(desWS.[DC330], "yyyy-mm-dd"): maxDate = Format(desWS.[CV330], "yyyy-mm-dd") 'قم بتحديد مسار حفظ الملف بما يناسبك 'Path = "C:" ' المسار الافتراضي للملف الرئيسي Path = Application.ActiveWorkbook.Path 'اسم الملف المستخرج sFile = minDate & " " & "الفواتير من" & " " & maxDate & " " & "الى" ' اسم مجلد الحفظ FolderName = "raed": 'شرط فواصل الصفحات myValue = "اجمالى الواصل" If Len(desWS.[CA328].Value) = 0 Then Exit Sub Application.ScreenUpdating = False On Error Resume Next WS.Visible = xlSheetVisible: WS.Cells.Clear For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i With ActiveWorkbook sPath = Path & Application.PathSeparator & FolderName & Application.PathSeparator If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath MyRng.Copy LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 4 With WS.Range("A" & LR) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With End With Next i With WS fRow = .Range("a:o").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set FndRng = .Range("j10:j" & fRow) Set Cpt = FndRng.Find(What:=myValue, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not Cpt Is Nothing Then: Linge = Cpt.Address Do If Not Cpt Is Nothing Then: Cpt.Offset(2).PageBreak = xlPageBreakManual Set Cpt = FndRng.FindNext(Cpt) If Cpt Is Nothing Then: Exit Do If Cpt.Address = Linge Then: Exit Do Loop WS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 End With WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.Visible = xlSheetVeryHidden On Error GoTo 0 Application.ScreenUpdating = True End Sub Book2.xls

تفضل تم اظافة ورقة خاصة باسم فلترة البيانات وبالاعتماد عليها ستتمكن من فلترة بياناتك بين تاريخين مع ترحيل النتائج الى ملف اكسيل مستقل او او ملف PDF على حسب اختيارك الاكواد الخاصة بهدا الملف تختلف نوعا ما عن الملف السابق ودالك بتنقيحها بشكل مختلف مع اظافة كود خاص بترحيل ملفات PDF وانشاء لكل يوم مجلد مستقل '*****انشاء مجلدات لكل يوم مستقل*** Public Sub Save_folder_PDF() Dim Path$, sFile$, folderName$, fileName$, fileType$ Dim Cpt As String, PDFfile As String Dim lastRow As Long, LastCol As Integer Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("فلترة البيانات"): testDate = Now() fileType = "تقارير": folderName = "ملفات PDF": sFile = UCase(Format(testDate, "h\hmm")) & " " & "تقرير النشاط" Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, ": تأكيد ") If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible If WorksheetFunction.CountA(printing.Cells) = 0 Then MsgBox " ! لا توجد بيانات للحفظ", vbOKOnly + vbInformation Exit Sub End If LastCol = WS.Rows(2).Find("*", WS.Cells(2, WS.Columns.Count), , , , 2).column lastRow = WS.Columns(1).Find("*", WS.Cells(WS.Rows.Count, 1), , , , 2).Row ' Path = "C:" '" قم بتحديد مسار حفظ الملفات على حسب احتياجاتك ' المسار الافتراضي للملف الرئيسي Path = Application.ActiveWorkbook.Path If Right(Path, 1) <> "\" Then Path = Path & "\" Cpt = Path & folderName & "\" If Dir(Cpt, vbDirectory) = vbNullString Then MkDir Cpt Cpt = Cpt & UCase(Format(Date, "yyyy-mm-dd")) & " " & fileType & "\" If Dir(Cpt, vbDirectory) = vbNullString Then MkDir Cpt PDFfile = Cpt & sFile & ".pdf" WS.PageSetup.PrintArea = _ WS.Range("A2", WS.Cells(lastRow, LastCol)).Address WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=PDFfile, _ Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "": WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbInformation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub Save_As_PDF() 'انشاء مجلد في نفس مسار الملف Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("فلترة البيانات") Dim F As Worksheet: Set F = printing sFile = "تقرير النشاط": folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, F.Name) If Msg <> vbYes Then Exit Sub F.Visible = xlSheetVisible LastCol = F.Rows(2).Find("*", F.Cells(2, F.Columns.Count), , , , 2).column lastRow = F.Columns(1).Find("*", F.Cells(F.Rows.Count, 1), , , , 2).Row With ActiveWorkbook sPath = .Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath F.PageSetup.PrintArea = _ F.Range("A2", F.Cells(lastRow, LastCol)).Address F.ExportAsFixedFormat Type:=xlTypePDF, _ fileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False F.PageSetup.PrintArea = "" F.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub بالنسبة لكود الفلترة وانشاء ملف Excel مستقل ستجده داخل الملف المرفق بالتوفيق ............ فلترة وحفظ الملفات V2.xlsm

السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم printing Sub FilterByDate() Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing Dim MinDate As Date, MaxDate As Date, lr As Long Dim a As Range, r As Long MinDate = desWS.[d2]: MaxDate = desWS.[f2] Application.ScreenUpdating = False If MinDate > MaxDate Then: Exit Sub If Len(desWS.[f2]) > 0 And IsDate(desWS.[d2]) Then If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A7:K7") .AutoFilter 3, ">=" & CLng(MinDate), 1, "<=" & CLng(MaxDate) lr = WS.Columns("A:K").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A" & lr & ":k" & lr).SpecialCells(xlCellTypeVisible) If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then desWS.Range("A5:K" & Rows.Count).Clear With rng Cpt = Split("A,B,C,D,E,F,G,H,I,J,k", ",") Col = Split("A,B,C,D,E,F,G,H,I,J,k", ",") For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "8:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "5") Next i End With lige = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Cpt1 = "=IF(c5="""","""",IF(c5=""Name"",""Count"",N(b4)+1))" Cpt2 = "=IF(ISBLANK(b5),"""",SUBTOTAL(3,B$5:B5))" With desWS .Range("B5:B" & lige).Formula = Cpt1: .Range("A5:A" & lige).Formula = Cpt2 .Range("A5:B" & lige).Value = .Range("A5:B" & lige).Value End With End If .AutoFilter End With f.Range("A2:K" & f.Rows.Count).Clear Set a = desWS.Range("A4", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 11 Set a = Union(a, Intersect(a.EntireRow, Columns(r))) Next r a.Copy Destination:=f.Range("a2") End If Application.ScreenUpdating = True End Sub لحفظ الملف بصيغة PDF Sub Save_folder_PDF() Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing sFile = "تقرير النشاط" folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, f.Name) If Msg <> vbYes Then Exit Sub f.Visible = xlSheetVisible With ActiveWorkbook sPath = .path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath f.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub لحفظ التقرير في ملف مستقل Sub Save_folder_Excel() Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim path As String, folderName As String, sMsg As String Dim newWb As Workbook, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Set newWb = ActiveWorkbook newWb.SaveAs FileName:=path & Fname & ".xlsx", FileFormat:=51 newWb.Close WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub فلترة وحفظ PDF +EXCEL.xlsm

جرب هل هدا ما تقصده إنتهاء الرحصة.xlsm

يمكنك جلب اول تاريخ استلام باستخدام المعادلة التالية فقط لاكن دون شرط الاسم بمعني اول تاريخ مدخل على الصف =IFERROR(INDEX(البيانات!B$1:M$1; MATCH(TRUE; INDEX(البيانات!B2:M2<>""; 0); 0));"لم يستلم") لهدا سنقوم بتعديل المعادلة بالشكل التالي لاظافة شرط الاسم الموجود في العمود A =IF(A2<>"";IFERROR(INDEX(البيانات!$1:$1;AGGREGATE(15;6;COLUMN(البيانات!$B$1:$M$1)/ (INDEX(البيانات!$B$2:$M$11;MATCH(A2;البيانات!$A$2:$A$11;0);0)<>"");1));"لم يستلم");"") الكود يشتغل عندي بشكل جيد لااعلم صراحة ما سبب عدم اشتغاله معك على العموم قم بتجربة الكود التالي بعد اظافة معادلة جلب اول تاريخ استلام في عمود D Sub test() Dim lastrow As Long, lige As Long, lastcol As Long Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("الخلاصة") With Application .ScreenUpdating = False .Calculation = xlManual F = WS.Name '***جلب الاسماء من ورقة البيانات بدون تكرار مع تجاهل الفراغات***** Set Cpt = CreateObject("Scripting.Dictionary") a = Range(WS.[A2], WS.[a65000].End(xlUp)).Value For Each c In a Cpt(c) = "" Next c Set dest = desWS.[A2] desWS.Range("A2:D" & Rows.Count).ClearContents dest.Resize(Cpt.Count, 1) = Application.Transpose(Cpt.keys) ' ترتيب ابجدي dest.Resize(Cpt.Count, 1).Sort Key1:=dest, Order1:=xlAscending Set Cpt = Nothing lastrow = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastcol = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column lige = desWS.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' نطاق البيانات Set a = WS.Range("B2:M" & lastrow): Set B = WS.Range("A2:A" & lastrow) ' رؤوس الاعمدة Set c = WS.Range("B1", WS.Cells(1, lastcol)) Set r = WS.Range("$1:$1") ' جلب اخر تاريخ استلام بشرط الاسم With desWS.Range("B2:B" & lige) .Formula = "=IFERROR(IF(NOT(ISBLANK('" & desWS.Name & "'!A2)),LOOKUP(2,1/INDEX('" & F & "'!" & a.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0),'" & F & "'!" & c.Address & "),""""),""لم يستلم"")" ' جلب مجموع قيم الصف بشرط الاسم With desWS.Range("C2:C" & lige) .Formula = "=IFERROR(SUM(INDEX('" & F & "'!" & a.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0)),"""")" ' جلب اول تاريخ استلام بشرط الاسم With desWS.Range("D2:D" & lige) .Formula = "=IF('" & desWS.Name & "'!A2<>"""",IFERROR(INDEX('" & F & "'!" & r.Address & ",AGGREGATE(15,6,COLUMN('" & F & "'!" & c.Address & ")/(INDEX('" & F & "'!" & a.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0)<>""""),1)),""لم يستلم""),"""")" ' Range("B2:D" & lige).Value = Range("B2:D" & lige).Value End With End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub جلب اول واخر الاستلامات + المجموع.rar

وعليكم السلام ورحمة الله تعالى وبركاته لجلب اخر تاريخ استلام =IFERROR(IF(NOT(ISBLANK(A2));LOOKUP(2;1/INDEX(البيانات!$B$2:$M$11;MATCH(A2;البيانات!$A$2:$A$11;0);0) ;البيانات!$B$1:$M$1);"");"لم يستلم") لجلب المبلغ الكلي =IFERROR(SUM(INDEX(البيانات!$B$2:$M$11;MATCH(A2;البيانات!$A$2:$A$11;0);0));"") لجلب اخر قيمة مدخلة =IFERROR(LOOKUP(2;1/INDEX(البيانات!$B$2:$M$11;MATCH(الخلاصة!A2;البيانات!$A$2:$A$11;0);0);البيانات!B2:M2);"لم يستلم") في حالة الرغبة باستخدام الاكواد Sub test() Dim lastrow As Long, lige As Long, lastcol As Long Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("الخلاصة") With Application .ScreenUpdating = False .Calculation = xlManual F = WS.Name lastrow = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastcol = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column Set A = WS.Range("B2:M" & lastrow): Set B = WS.Range("A2:A" & lastrow) Set C = WS.Range("B1", WS.Cells(1, lastcol)) lige = desWS.Range("A:D").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row desWS.Range("B2:C" & lige).ClearContents With desWS.Range("B2:B" & lige) .Formula2 = "=IFERROR(IF(NOT(ISBLANK('" & desWS.Name & "'!A2)),LOOKUP(2,1/INDEX('" & F & "'!" & A.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0),'" & F & "'!" & C.Address & "),""""),""لم يستلم"")" .Value = .Value With desWS.Range("C2:C" & lige) .Formula2 = "=IFERROR(SUM(INDEX('" & F & "'!" & A.Address & ",MATCH('" & desWS.Name & "'!A2,'" & F & "'!" & B.Address & ",0),0)),"""")" .Value = .Value End With End With .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub بالتوفيق........... التاريخ الاخير الذي استلم Formula.xlsx التاريخ الاخير الذي استلم VBA.xlsb

قم باستبدالها الى ws.Cells(ligne, 1) = Me.TextBox1.Text وفي كود التعديل f.Cells(LigneN_Row, 1) = Me.TextBox1 وفي عمود حالة الاجازة يمكنك تجربة المعادلة التالية بدون الاعتماد على الخلية (1M) =IF(ISBLANK(H3);"";IF(H3<TODAY();"باشر";"يتمتع")) عند كتابة الكود يأتي الاسم -تحديث1.xlsb

السبب هو الصفوف الفارغة الموجودة اسفل الجدول حاول اعادة تسمية النطاق بالشكل التالي =OFFSET(Produits!$N$2;;;COUNTA(Produits!$N:$N)-1) ووضع هدا الكود في موديول Sub Delete() Dim i As Long On Error Resume Next Application.ScreenUpdating = False With Worksheets("Produits").ListObjects("T_listrayon") For i = .ListRows.Count To 1 Step -1 If .ListRows(i).Range.Cells(1) = "" Then .ListRows(i).Delete End If Next i End With Application.ScreenUpdating = True End Sub Sub afformulaire() On Error Resume Next Call Delete Sheets("ACCUEIL").Activate: Formulaire.MultiPage1.Value = 0: Formulaire.Show modal End Sub Gest_magasin2.xlsm

المرجوا توضيح الطلب الاول او ارفاق عينة للنتائج المتوقعة اما بالنسبة للطلب الثاني يمكنك استخدام الكود التالي لجلب اسم الموظف Private Sub TextBox1_Change() ' اسماء الموظفين Dim iRow, clé, Myrng, j, r, name$ Set j = Sheets("اسماء الموظفين") Set iRow = j.Range("A2:B" & j.[A65000].End(xlUp).Row) LR = j.Cells(Rows.Count, 1).End(xlUp).Row Myrng = iRow.Value: name = Me.TextBox1.Value Set r = j.Range("A2:A" & LR).Find(name) On Error Resume Next If Not r Is Nothing Then For k = 1 To UBound(Myrng) If Myrng(k, 1) = name Then clé = k Me.réf = clé + iRow.Row - 1: Me.TextBox2 = Myrng(clé, 2) End If Next k Else Me.TextBox2 = Empty End If If Me.TextBox1 = "" Then Me.TextBox2 = "": Me.réf = "" End Sub عند كتابة الكود يأتي الاسم.xlsb

جرب هدا Sub PrintArea() Dim F As Worksheet: Set F = Sheet1 Cpt = 18: A = 1: B = 4: C = 1 With F .PageSetup.PrintArea = "" .PageSetup.PrintArea = Range("A1", Cells(46, Cpt)).Address: .PrintOut Copies:=A .PageSetup.PrintArea = Range("A47", Cells(96, Cpt)).Address: .PrintOut Copies:=B .PageSetup.PrintArea = Range("A97", Cells(150, Cpt)).Address: .PrintOut Copies:=C End With End Sub او يمكنك تحديد الصفحات وعدد مرات الطباعة بالاعتماد على ورقة اخرى خاصة بالاعدادات كما في المثال التالي Public Property Get Sh_Print() As Worksheet: Set Sh_Print = Sheet1 End Property Public Property Get F() As Worksheet: Set F = Sheet2 End Property Sub To_print() déleteRow TbPage = F.[Tb_MiseEnPage] NbMax = UBound(TbPage) Cpt = Application.InputBox(Prompt:=" المرجوا ادخال رقم الصفحة المرغوب طباعتها (من 0 الى " & NbMax & ")", Title:="طباعة", Type:=1) Cpt = Int(Cpt) If Cpt < 1 Then Exit Sub If Cpt > NbMax Then: MsgBox " اخر صفحة على الملف هي : " _ & NbMax _ & "", vbExclamation, "المرجوا التحقق من رقم الصفحة المرغوب طباعتها": Exit Sub With Sh_Print .PageSetup.PrintArea = "" For i = 1 To Cpt With .PageSetup On Error Resume Next .PrintArea = TbPage(i, 2) & ":" & TbPage(i, 3): Copies = TbPage(i, 4) If Copies < 1 Then Copies = 1 .FitToPagesWide = 1 .FitToPagesTall = 1 On Error GoTo 0 End With Next End With Sh_Print.PrintOut Copies:=Copies End Sub '*********************************** Sub déleteRow() With F For i = F.[B65000].End(xlUp).Row To 2 Step -1 Application.ScreenUpdating = False If Application.CountA(Range(F.Cells(i, "B"), F.Cells(i, "C"))) = 0 Then F.Rows(i).Delete F.Range("A2:A" & Rows.Count).ClearContents Next i With F.Range("A2:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With End With Application.ScreenUpdating = True End Sub نمودج طباعة.xlsm

Private Sub TextBox7_Change() If IsDate(Me.TextBox7) And IsNumeric(Me.TextBox4) Then Me.TextBox8 = Format(CDate(Me.TextBox7) + CDbl(Me.TextBox4) - 1, "yyyy/mm/dd") Else Me.TextBox8 = "" End If End Sub تنسيق التاريخ و اظافة و تعديل.xlsb

بطريقة اخرى Sub split2() Dim sh As Worksheet, Cpt For Each sh In ThisWorkbook.Worksheets Set F = Sheets(1) If sh.Name <> F.Name Then Cpt = Cpt & "|" & sh.Name Next sh With Application .ScreenUpdating = False .DisplayAlerts = False Cpt = split(Mid(Cpt, 2), "|") Sheets(Cpt).Copy With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, _ InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51 .Close End With .ScreenUpdating = True .DisplayAlerts = True End With End Sub Or Dim sh As Worksheet, Cpt For Each sh In ThisWorkbook.Worksheets If sh.Name <> "الرئيسية" Then Cpt = Cpt & "|" & sh.Name Next sh تصدير أروق عمل.xls

جرب هدا تنسيق التاريخ و اظافة و تعديل.xlsb

ببساطة يمكنك الغاء السطر On Error Resume Next: F.Sheets(1).Delete: On Error GoTo 0 ومعاينة الملف بعد تنفيد الكود واختيار ما يناسبك 😉

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub split() Dim Wb As Workbook, Ws As Worksheet Dim F As Workbook, filePath As String, Cpt() filePath = Application.ActiveWorkbook.Path: Set Sh = Sheets(1) '("الرئيسية") With Application .ScreenUpdating = False .DisplayAlerts = False Set Wb = ActiveWorkbook: Set F = Workbooks.Add For Each Ws In Wb.Worksheets If Ws.Name <> Sh.Name Then n = n + 1 ReDim Preserve Cpt(1 To n) Cpt(n) = Ws.Name End If Next Ws Wb.Sheets(Cpt).Copy After:=F.Sheets(F.Sheets.Count) On Error Resume Next: F.Sheets(1).Delete: On Error GoTo 0 Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & Wb.Name & ".xlsx" F.Close .ScreenUpdating = True .DisplayAlerts = True End With End Sub تصدير أروق عمل.xls

جرب هذا Private Sub Worksheet_Change(ByVal Target As Range) Dim Patch As String, Img As Boolean, Strfile As String, Imgfile As String If Not Intersect(Target, Range("k3")) Is Nothing Then Dim rng As Range, Clé As String, Cpt As Long Set WS = Feuil1: Set dest = Feuil2: Clé = dest.[k3] Set rng = WS.Columns("A:A").Find(What:=Clé, _ LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) Cpt = rng.Row dest.[F7] = WS.Cells(Cpt, 2).Value dest.[G7] = WS.Cells(Cpt, 3).Value dest.[H7] = WS.Cells(Cpt, 4).Value dest.[I7] = WS.Cells(Cpt, 5).Value dest.[J7] = WS.Cells(Cpt, 6).Value dest.[K7] = WS.Cells(Cpt, 7).Value dest.[L3] = WS.Cells(Cpt, 8).Value Patch = ThisWorkbook.Path Img = False On Error Resume Next Strfile = Dir(Patch & "\" & [L3].Value & ".*") Do While Len(Strfile) > 0 If Len(Strfile) <> 0 Then Img = True Imgfile = Strfile Exit Do Else End If Loop If Img = True Then Me.Image1.Picture = LoadPicture(Patch & "\" & Imgfile) Me.Image1.PictureSizeMode = fmPictureSizeModeZoom Me.Image1.Left = [L6].Left: Me.Image1.Top = [L6].Top On Error GoTo 0 Else MsgBox ("الصورة غير متوفرة") Me.Image1.Picture = Nothing End If End If End Sub test.rar

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