محمد هشام.

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

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

قم بتعديل هذا السطر For Each pic In WS.Pictures الى For Each pic In f.Pictures

وعليكم السلام ورحمة الله نعالى وبركاته اظن انه يجب عليك اولا تغيير مكان خلية اختيار اسم المادة (N1) خارج نطاق البحث لانه في حالة تم اخفاء عمود مادة الدين مثلا عمود (N) سيتم اخفاء خلية الاختيار لنفترض ان الخلية المحددة هي (R1) Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Target.Worksheet.Range("R1")) Is Nothing Then Dim x As Range, rng As Range Set x = Clé([R1], [G7:P7]): Set rng = Columns("E:F") Application.ScreenUpdating = False If x Is Nothing Then MsgBox "مادة" & " " & [R1] & " : " & " غير موجودة ", vbExclamation: Exit Sub Columns("C:P").EntireColumn.Hidden = True x.EntireColumn.Hidden = False: rng.EntireColumn.Hidden = False ActiveWindow.ScrollColumn = 1 End If End Sub Function Clé(a, b As Range) As Range Dim i& On Error Resume Next i = WorksheetFunction.Match(a, b, 0) If i Then Set Clé = b(i) End Function اظهار الاعمدة Sub Show_all_columns() Sheets("Sheet1").Columns("C:P").EntireColumn.Hidden = False End Sub بطريقة اخرى Sub Hide_columns() Dim Clé As Variant, desWS As Worksheet, rng As Range Set desWS = ThisWorkbook.Sheets("Sheet1"): Clé = [R1].Value If Clé > 0 Then With desWS Set rng = .Rows(7).Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Application.ScreenUpdating = False .Columns("C:P").EntireColumn.Hidden = True rng.EntireColumn.Hidden = False .Columns("E:F").EntireColumn.Hidden = False Else MsgBox "مادة" & " " & Clé & " : " & " غير موجودة ", vbExclamation: Exit Sub End If End With End If ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = True End Sub صفحة الرصد V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لجلب الصور دفعة واحدة يكفي الوقوف بمؤشر الماوس على اول خلية فارغة على عمود الصور وتشغيل الكود التالي مع تحديد الصور المرغوب اظافتها Sub InsertMultiplePictures() 'اظافة الصور' Set WS = Sheets("ادخال البيانات") Dim Pictures() As Variant Dim j As String, Rng As Range, Cpt As Shape On Error Resume Next Pictures = Application.GetOpenFilename(j, MultiSelect:=True) a = Application.ActiveCell.Column If IsArray(Pictures) Then Col = Application.ActiveCell.Row For lLoop = LBound(Pictures) To UBound(Pictures) Set Rng = Cells(Col, a) Set Cpt = WS.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) Col = Col + 1 Next End If End Sub لافراغ عمود الصور Sub DeleteImage() Dim pic As Picture Set f = Sheets("ادخال البيانات") For Each pic In WS.Pictures If Not Application.Intersect(pic.TopLeftCell, f.Range("G6:G200")) Is Nothing Then pic.Delete End If Next pic End Sub الجدول 1 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$10;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture الجدول 2 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$36;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture2 واخيرا ربط الصور بالنطاق الجمعيه الخيريه 2.xlsb

😁😁😁 بارك الله في اخي سعد يسعدنا اننا استطعنا مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub TextBox1_Change() Dim a As Variant, b As Variant, Clé$, Rng As Range, i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("donnes") Dim desWS As Worksheet: Set desWS = Worksheets("search") Clé = "*" & desWS.[B3].Value & "*" Set Rng = desWS.Range("A6:G" & Rows.Count) a = WS.Range("D5", WS.Range("J" & Rows.Count).End(3)).Value If Me.TextBox1 = "" Then Rng.ClearContents Else Application.ScreenUpdating = False With desWS On Error Resume Next .AutoFilterMode = False ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) 'Filter by Uppercase and lowercase letters If LCase(a(i, j)) Like Clé Or UCase(a(i, j)) Like Clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next Rng.ClearContents: Range("A6").Resize(k, UBound(b, 2)).Value = b Range("d6:d" & Rows.Count).NumberFormat = "dd-mm-yyyy" End With End If Application.ScreenUpdating = True End Sub بحث VBA V2.xlsm

تفضل تم تعديل النسخ بداية من الصف 10 اما بخصوص التنسيق في الصورة فوق ليس له اي علاقة بالبيانات الخاصة بك اظافة اخي الفاضل انت تشتغل على يوزرفورم بمعنى التعامل و الترحيل يكون على حسب البيانات الموجودة في الليست بوكس لا اقل ولا اكثر ملاحظة تمت اظافة المعادلة المقترحة من طرف الاخ إيهاب عبد الحميد في اخر مشاركة لك للتجربة مستخلصات الاعمال الجنوبية- V4.xlsm

نعم اخي لاننا قمنا بعرض البيانات على الليست بوكس بداية من العمود رقم 2 (التاريخ) فمن الطبيعي عند الترحيل سيتم نسخ البيانات بداية من نفس العمود حاول اخي في المرة المقبلة تزويد طلبك بمعطيات كافية .تفاديا لاهدار الوقت والاشتغال على الملف اكثر من مرة .فمسالة التعديل ليست بالسهلة . على العموم تفضل اخي تم نعديل اكواد الترحيل وانشاء صفحات المقاولين مع مراعات جميع الاحتمالات الواردة على ما اظن في انتظارك بعد التجربة..........😁 كلمة المرور 0 مستخلصات الاعمال الجنوبية- V3.xlsm

تفضل اخي مستخلصات الاعمال الجنوبية- V2.xlsm