محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته 1) هل البحث سيكون في عمود معين او في كل الاعمدة من A الى J 2) نطاق البيانات لديك على الملف يبدأ من الخلية a2 والكود يتضمن (a12:j"& lastrow100") !!!!

وعليكم السلام ورحمة الله تعالى وبركاته Sub Merger() Dim srcWS As Variant, _ WS As Worksheet, _ I As Long, nCount As Integer Const rCrit As String = "دمج" Const P As String = "%" nCount = 4 Set WS = Sheets("dmg1"): srcWS = Array("1", "2", "3") Application.ScreenUpdating = False WS.Range("b4:f" & WS.Rows.Count).ClearContents For Each arr In Worksheets(srcWS) a = arr.Range("A2:G" & arr.Range("A" & arr.Rows.Count).End(xlUp).Row).Value tmp = arr.[C1] For I = 1 To UBound(a) If a(I, 2) > 0 And a(I, 5) = rCrit _ And a(I, 6) > 0 Then WS.Range("b" & nCount).Resize(1, 5).Value _ = Array((a(I, 1)), (a(I, 2)), (a(I, 6)), _ (a(I, 7) & P), tmp) nCount = nCount + 1 With WS.Range("B4:B" & WS.Cells(Rows.Count, "C").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With End If Next Next arr Application.ScreenUpdating = True End Sub وفي حدث ورقة (dmg1) Private Sub Worksheet_Activate() Merger End Sub ahmed v2.xlsb

جرب هل هدا ما تقصده smr (1)v2.xlsm

اسف اخي على التاخير في الرد لاكنني عند الاشتغال على الملف ومراجعة الاكواد لاحظت بعد الهفوات التي لم انتبه اليها من قبل 😱 ربما انت لم تلاحظها لاكنها حتما سوف تسبب لك اخطاء بعد تحديث البيانات وخاصة عند اظافة بيانات جديدة لم تكن موجودة مسبقا على الملف ...... (رحم الله من عمل عملا فأتقنه) تفضل استبدل كود التوزيع بالكود التالي بعد تنقيحه بشكل افضل وادق Sub Create_Worksheets() '09/05/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '*********'Create Worksheets and Name Them With The First letters of The Name*********** Dim WS As Worksheet, srcWS As Worksheet Dim rgData As Range, ColName As Variant Dim Lr As Long, lColumn As Long, Irow As Long Dim rCrit As Range, destRng As Range, tmp As Range Dim dicWS As Object, dictKey As String, Cpt As Variant Dim I As Long, x As Long, nCount As Integer, lastRow As Long With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With ' نطاق المعايير Set WS = Worksheets("البيانات") With WS .Columns("J:G").Clear: .UsedRange.Hyperlinks.Delete Lr = .Cells(Rows.Count, "D").End(xlUp).Row lColumn = .Cells(1, Columns.Count).End(xlToLeft).Column + 2 Set rgData = .Range("C1:E" & Lr) ColName = rgData.Columns(2) Set rCrit = .Cells(1, lColumn) rCrit.Value = .Range("D1") Set rCrit = .Cells(1, lColumn).Resize(2) End With ' الحصول على مجموعة الحروف الفريدة - الحرف الأول من الاسم Set dicWS = CreateObject("Scripting.dictionary") dicWS.comparemode = vbTextCompare For I = 2 To UBound(ColName) ' تجاهل الفراغات If ColName(I, 1) <> "" Then dictKey = Left(ColName(I, 1), 1) If Not dicWS.Exists(dictKey) Then dicWS(dictKey) = "" End If End If Next I ' رمز اظافي للتعامل مع حرف الالف '(ا,أ,إ,آ) & Unicode & وتجميعه والذي يمكن أن يكون 4 أحرف مختلفة Dim letters As Variant, réf As Boolean, arr() As String, j As Long letters = Array(1570, 1571, 1573, 1575) ReDim arr(1 To UBound(letters) + 1) For I = 0 To UBound(letters) dictKey = ChrW(letters(I)) If dicWS.Exists(dictKey) Then réf = True dicWS.Remove dictKey End If j = j + 1 arr(j) = dictKey & "*" Next I If réf Then dictKey = Replace(Join(arr, "-"), "*", "") dicWS(dictKey) = "" End If '*مراجعة المعرفات مع إنشاء أو تحديث ورقة جديدة للمجموعة الحرفية *** For Each Cpt In dicWS.Keys ' ***التحقق من وجود ورقة العمل مسبقا*** If Evaluate("ISREF('" & Cpt & "'!A1)") Then 'تحديث Set srcWS = Worksheets(Cpt) srcWS.UsedRange.Clear Else ' اظافة Set srcWS = Worksheets.Add(after:=Sheets(Sheets.Count)) srcWS.Name = Cpt End If ' لصق البيانات Set tmp = srcWS.[A1] If Len(Cpt) > 1 Then rCrit.Cells(2).Resize(UBound(arr)) = Application.Transpose(arr) Set rCrit = rCrit.CurrentRegion Else rCrit.Offset(1).ClearContents rCrit.Cells(2) = Cpt & "*" Set rCrit = rCrit.CurrentRegion End If rgData.AdvancedFilter xlFilterCopy, rCrit, tmp rgData.EntireColumn.Copy tmp.PasteSpecial Paste:=xlPasteColumnWidths ' اظافة ارتباط تشعبي لاوراق المجوعات الحرفية Worksheets(srcWS.Name).Hyperlinks.Add Anchor:=Worksheets(srcWS.Name).[E2], Address:="", _ SubAddress:="'" & WS.Name & "'" & "!A1", TextToDisplay:="ورقةالبيانات" lastRow = srcWS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row '***(ازالة التكرار في حالة وجوده (على الاوراق الجديدة *** 'الاعمدة d = [{1,2,3}] srcWS.Range(srcWS.Cells(1, 1), srcWS.Cells(lastRow, 3)).RemoveDuplicates d(1), Header:=xlNo ' اعادة ترتيب التسلسل With srcWS.Range("A2:A" & srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row) .Formula = "=IF(B2="""","""",IF(B2=""Name"",""Count"",N(A1)+1))" .Value = .Value End With Next Cpt rCrit.EntireColumn.Clear ' تحديد اوراق المجموعات الحرفية For x = 1 To Sheets.Count nf = Sheets(x).Name If Len(nf) = 1 Or (nf) Like "*-*" Then Sheets(x).Activate With ActiveSheet 'عدد الاسماء على كل ورقة lige = Evaluate("SUM(0+(A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row & "<>""""))") ' اظافة الارتباط التشعبي لجميع الاوراق الى الرئيسية WS.Hyperlinks.Add Anchor:=WS.Cells(x + 2, 10), Address:="", SubAddress:="'" & _ nf & "'" & "!A1", TextToDisplay:="حرف" & "-" & nf .Tab.Color = 5287936: [A1].Select: .DisplayRightToLeft = True: .[f1] = "عدد الاسماء": .[f2] = lige End With ' استخراج اسماء المجموعات الحرفية nams = nams & " " & "حرف" & "-" & nf nCount = nCount + 1 End If Next x ' ترتيب ابجدي لاسماء الشيتات Irow = WS.Range("j:j").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row WS.Range("j2:j" & Irow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp WS.Range("j1:j" & Irow).Sort Key1:=WS.[j2], _ Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom WS.Activate With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .CalculateFull End With MsgBox nams, vbInformation, "تم حفظ" & " : " & nCount & " " & "مجموعة بنجاح" End Sub اما لطلبك لحفظ الملفات بصيغة PDF تفضل اخي نظرا لعدد اوراق العمل الكثيرة على الملف التي يجب تنسيقها قبل الطباعة او الحفظ سرعة تنفيد الكود ستعتمد على امكانيات الجهاز المستخدم Sub Save_PDF() Dim wb As Workbook, _ WS As Variant, _ lastRow As Long, _ nCount As Integer, strFolder As String Const File_format As String = ".pdf" ' قم بتعديل اسم مجلد الحفظ بما يناسبك strFolder = "المجموعات الحرفية" Set wb = ActiveWorkbook: With Application .ScreenUpdating = False If MsgBox("؟" & " PDF" & " : " & " حفط الملفات ", vbYesNo) = vbNo Then Exit Sub For Each WS In wb.Worksheets If Len(WS.Name) = 1 Or (WS.Name) Like "*-*" Then Cpt = True j = "حرف" & "-" & WS.Name nCount = nCount + 1 lastRow = WS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row With wb On Error Resume Next SaveLocation = wb.Path & Application.PathSeparator & strFolder If Len(Dir(SaveLocation, vbDirectory)) = 0 Then End If MkDir SaveLocation End With ' الاعدادات With WS.PageSetup .PrintArea = "$A$1:$C$" & lastRow .PrintTitleRows = "$1:$1" .CenterHorizontally = True .CenterVertically = True .Orientation = xlLandscape .CenterFooter = j End With WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SaveLocation & Application.PathSeparator & j & File_format, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Next WS .ScreenUpdating = True End With If Cpt = False Then MsgBox "لا توجد ملفات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub End If MsgBox "تم حفظ" & " : " & nCount & " " & "مجموعة بنجاح", _ vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, SaveLocation End Sub ترحيل الاسماء حسب الاحرف الى شيتات V3.xlsm

مادا غيرت اخي ممكن توضح اكثر لكي يتم تعديل الكود بما يناسبك

ولك بالمثل اخي الكريم يسعدنا أننا استطعنا مساعدتك سوف اقوم بتنفيذ طلبك عن قريب بإذن الله

تفضل اخي الكود طويل نوعا ما لاكنه سريع Sub Create_Worksheets() Dim desWS As Worksheet, srcWS As Worksheet Dim rCrit As Range, rngFilter As Variant Dim Irow As Long, LastCol As Long Dim rgData As Range, destRng As Range Dim Dic As Object, dictKey As String, Cpt As Variant Dim Destination As Range, i As Long Set desWS = Worksheets("البيانات") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next With desWS Irow = .Cells(Rows.Count, "D").End(xlUp).Row LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 2 Set rCrit = .Range("C1:E" & Irow): rngFilter = rCrit.Columns(2) ' نطاق المعايير Set rgData = .Cells(1, LastCol): rgData.Value = .[D1] Set rgData = .Cells(1, LastCol).Resize(2) End With ' الحصول على مجموعة الحروف الفريدة - الحرف الأول من الاسم Set Dic = CreateObject("Scripting.dictionary") Dic.CompareMode = vbTextCompare For i = 2 To UBound(rngFilter) dictKey = Left(rngFilter(i, 1), 1) If Not Dic.exists(dictKey) Then Dic(dictKey) = "" End If Next i ' رمز اظافي للتعامل مع حرف الالف '(ا,أ,إ,آ) & Unicode & وتجميعه والذي يمكن أن يكون 4 أحرف مختلفة Dim a As Variant, b As Boolean, Clé() As String, j As Long a = Array(1570, 1571, 1573, 1575) ReDim Clé(1 To UBound(a) + 1) For i = 0 To UBound(a) dictKey = ChrW(a(i)) If Dic.exists(dictKey) Then b = True Dic.Remove dictKey End If j = j + 1 Clé(j) = dictKey & "*" Next i If b Then dictKey = Replace(Join(Clé, ","), "*", "") Dic(dictKey) = "" End If '*مراجعة المعرفات مع إنشاء أو تحديث ورقة جديدة للمجموعة الحرفية *** For Each Cpt In Dic.keys ' ***التحقق من وجود ورقة العمل مسبقا*** If Evaluate("ISREF('" & "حرف" & "-" & Cpt & "'!A1)") Then Set srcWS = Worksheets(Cpt) srcWS.UsedRange.Clear Else Set srcWS = Worksheets.Add(After:=Sheets(Sheets.Count)) srcWS.Name = "حرف" & "-" & Cpt: Set Destination = srcWS.[A1] End If '** تصفية If Len(Cpt) > 1 Then rgData.Cells(2).Resize(UBound(Clé)) = Application.Transpose(Clé) Set rgData = rgData.CurrentRegion Else rgData.Offset(1).ClearContents rgData.Cells(2) = Cpt & "*" Set rgData = rgData.CurrentRegion End If rCrit.AdvancedFilter xlFilterCopy, rgData, Destination '***تنسيق عرض عمود المصدر*** rCrit.EntireColumn.Copy srcWS.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths [A1].Select: ActiveSheet.DisplayRightToLeft = True Dim nCount As Integer, shName As Range, lastrow As Long '***(ازالة التكرار في حالة وجوده (على الاوراق الجديدة *** lastrow = srcWS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row 'الاعمدة arr = [{1,2,3}] srcWS.Range(Cells(1, 1), srcWS.Cells(lastrow, 3)).RemoveDuplicates arr(1), Header:=xlNo Next Cpt 'اظافة الارتباط التشعبي desWS.Columns("J:G").Clear: desWS.UsedRange.Hyperlinks.Delete j = 2 For Each WS In ThisWorkbook.Worksheets If WS.Name Like "*ح*" Then nCount = nCount + 1 ActiveWorkbook.Sheets("البيانات").Hyperlinks.Add _ Anchor:=ActiveWorkbook.Sheets("البيانات").Cells(j, 10), Address:="", SubAddress:="'" & WS.Name & "'!A1", _ TextToDisplay:=WS.Name Worksheets(WS.Name).Hyperlinks.Add Anchor:=Worksheets(WS.Name).[E2], Address:="", _ SubAddress:="'" & desWS.Name & "'" & "!A1", TextToDisplay:="ورقةالبيانات" j = j + 1 End If Next WS ' استخراج اسماء المجموعات الحرفية Set shName = desWS.Range("j2", desWS.Range("j" & desWS.Rows.Count).End(xlUp)) For Each c In shName If WorksheetFunction.CountIf(shName, c) >= 1 Then If InStr(1, s, c) = 0 Then s = s & " ** " & c Next desWS.Activate .DisplayAlerts = True .ScreenUpdating = True End With resultat = IIf(s <> "", vbLf & Mid(s, 2), "") MsgBox resultat, vbInformation, "تم تحديث" & " : " & nCount & " " & "مجموعة بنجاح" End Sub ترحيل الاسماء حسب الاحرف الى شيتات V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لم تحدد اخي اين سيتم استدعاء البيانات بعد البحث مع العلم انه هناك تكرار لكود واسم العميل اكثر من مرة هل يتم جلبها كلها ام هناك شرط معين

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

العفو اخي يسعدنا اننا استطعنا مساعدتك اليك حل اخر في حالة الرغبة في عدم استخدام الجداول المحورية Sub FiltreListe() Dim srcWS, rCrit, Irow As Long, _ WS As Worksheet, _ desWS As Worksheet, _ ColLast As Long, _ rngFilter As Range, _ i As Long: Cpt = 5: Set WS = Sheets("Feuil1"): Set desWS = Sheets("Feuil2") Irow = WS.Columns("F:F").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row Set rCrit = desWS.[A2:A10]: arr = rCrit.Value srcWS = WorksheetFunction.CountA(desWS.Range("a2:a" & desWS.Rows.Count)) Dim b(): ReDim b(0 To UBound(arr)) On Error Resume Next For i = 0 To UBound(arr) If arr(i, 1) <> "" Then b(i) = CStr(arr(i, 1)) Next i If srcWS = 0 Then MsgBox "المرجوا ادخال عناصر الفلترة" _ & "", vbInformation, "انتباه": Exit Sub ColLast = WS.Cells(1, Columns.Count).End(xlToLeft).Column Set rngFilter = WS.Range(WS.Cells(1, "A"), WS.Cells(1, "H")) 'OR Until the last column 'Set rngFilter = WS.Range(WS.Cells(1, "A"), WS.Cells(Irow, ColLast)) With rngFilter If .AutoFilterMode Then .AutoFilterMode = False .AutoFilter Field:=Cpt, Criteria1:=b, _ Operator:=xlFilterValues j = Application.WorksheetFunction.Subtotal(3, WS.Range("F2:F" & Irow)) If j = 0 Then: MsgBox "لا توجد بيانات ", vbInformation, "تم إلغاء الإجراء": .AutoFilter: Exit Sub desWS.Range("D13:K" & desWS.Rows.Count).Clear WS.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).Copy desWS.[D13] .AutoFilter End With End Sub smr V2.xlsm

تفضل جرب هدا Public Sub Filter_data() Dim arrayCriteria(), _ desWS As Worksheet, _ lo As ListObject, _ rng As Range, _ Cpt As Long, _ i As Long Set lo = Range("Clé").ListObject Cpt = lo.ListRows.Count ReDim arrayCriteria(Cpt) For i = 1 To Cpt arrayCriteria(i) = CStr(lo.DataBodyRange.Cells(i, 1)) Next i Set rng = Range("T_data"): Set desWS = Sheets("Feuil2") If WorksheetFunction.CountA(lo.DataBodyRange) = 0 Then MsgBox "المرجوا ادخال معيار الفلترة": Exit Sub With rng.ListObject Application.ScreenUpdating = False If .ShowAutoFilter Then .AutoFilter.ShowAllData .Range.AutoFilter field:=5, Criteria1:=arrayCriteria, Operator:=xlFilterValues If (rng.Rows.Count > 1) Then desWS.Range("d13:k" & Rows.Count).Clear .AutoFilter.Range.Offset(1).SpecialCells(xlVisible).Copy desWS.[D13] [T_data].AutoFilter End If End With Application.ScreenUpdating = True smr.xlsm

ممكن توضح ما هي طريقة الاختيار المطلوبة

جرب هدا Option Explicit Private Sub Workbook_BeforePrint(Cancel As Boolean) If ThisWorkbook.ActiveSheet.Name = "Sheet1" Then Call Macro2 End If End Sub

رقم 15 هو يوم بداية الاسبوع كما جاء في طلبك اليك المرفق التالي ربما تتضح اليك الفكرة لتساعدك على تحديد الرقم المناسب لك او قم بكتابة تاريخ من اختيارك في الخلية A2 مثلا وجرب استخدام شيئ كهدا Sub TEST() Dim d As Integer d = InputBox("المرجوا ادخال رقم بداية الاسبوع ") Range("C2").Formula = "=weeknum(a2," & d & ")" End Sub '******************************* Sub TEST2() Dim week As Date 'خلية التاريخ week = Range("a2") 'هنا تم تحديد يوم الجمعة كاول يوم في الاسبوع d = 15 st = Application.WeekNum(week, d) MsgBox "رقم الاسبوع هو :" & " " & st, vbInformation End Sub بالتوفيق .... WEEKDAY.xlsx

للاسف غير مفهوم بالنسبة لي مادا تقصد بتنسيق الاسبوع يوم/شهر/سنة اما ادا كنت تقصد التواريخ عدل هدا الجزء من الكود a = Array("فواتير الأسبوع من", " ", CDate(desWS.[CV330]), " ", "إلى", " ", CDate(desWS.[DC330])) Set xDate = srcWS.Cells(2, lCol + 3).Offset(1).Resize(, 7) With xDate .Value = a: .Interior.Color = RGB(255, 255, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) If Not IsDate(xDate.Value) Then xDate.NumberFormat = "yyyy/mm/dd" ' قم بتعديل تنسيق التاريخ بما يناسبك End With Book معدل 3.xls

ادن اخي حاول التركيز معي سنشتغل على شيت الفواتير لترحيل البيانات اليه مع مراعات عدم تكرار الفواتير في حالة وجودها مسبقا اعتمادا على رقم الاسبوع الدي سيتم اظافته تلقائيا استنادا الى اخر تاريخ للفواتير المرحلة ويوم بداية الاسبوع الافتراضي بالنسبة لك هو يوم (الجمعة) مع اخد في عين الاعتبار تنسيق وشكل البيانات بعد كل ترحيل المطلوب مسبقا الاكواد طويلة نوعا ما بسبب التنسيقات المطلوبة لاكنها سريعة في التنفيد 😉 كود الترحيل Sub Copy_data() Dim StDate$, EnDate$, iCnt&, fRow&, Invoice$ Dim rngMain As Range, rngCount, LR&, x& Dim arrMain As Variant, arrCount() As Variant, sht As Worksheet Dim Cpt As Range: Dim FndRng As Range: Dim MyRng As Range: Dim c As Range Dim week As Date: Dim i As Integer: Dim Clé As Range: Dim xDate As Range Dim d As Integer: Dim FindWeek As Range: Dim OneRng As Range: Dim n As Range Dim desWS As Worksheet: Set desWS = ActiveSheet Dim srcWS As Worksheet: Set srcWS = Sheets("فواتير الاسبوع") Dim WS As Worksheet: Set WS = sheet1 Set Clé = desWS.[BU331]: Set MyRng = desWS.[BW330:CK372] StDate = desWS.[CA328]: EnDate = desWS.[CE328] week = desWS.[DC330].Value d = 15 ' اليوم الافتراضي لبداية الأسبوع (الجمعة) st = Application.WeekNum(week, d) On Error Resume Next Application.ScreenUpdating = False If Len(desWS.[CA328].Value) = 0 Then Exit Sub Set FindWeek = srcWS.Rows(3).Find(what:=st, LookIn:=xlValues, _ LookAt:=xlWhole) If Not FindWeek Is Nothing Then If MsgBox(" تم ترحيل فواتير الأسبوع" & " " & st & " :" & "مسبقا" & Chr(10) & Chr(10) _ & " معاينة الفاتورة" & "؟", vbYesNo, "تم إلغاء الإجراء") = vbYes Then Dim cel As Range Invoice = st.Value For Each c In srcWS.Rows(3) If c.Value = Invoice Then Set cel = srcWS.Range(FindWeek.Address) Application.GoTo Reference:=cel ActiveWindow.ScrollColumn = cel.Column - 13: ActiveWindow.ScrollRow = cel.Row - 2 Exit Sub Next End If Exit Sub Else With Application .ScreenUpdating = False .DisplayAlerts = False WS.Cells.Clear For i = StDate To EnDate: Clé.Value = i MyRng.Copy If WorksheetFunction.CountA(WS.Cells) = 0 Then LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 1 Else LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 3 End If With WS.Range("A" & LR) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With Next i fRow = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape For i = 1 To fRow Step 45 j = j + 1 WS.HPageBreaks.Add WS.Range("A" & i) Next i WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j Set sht = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Range("A1:O" & fRow + 1).Copy With sht.Range("b" & Rows.Count).End(xlUp)(2) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Irow = sht.Range("A:P").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 Set rngMain = sht.Range("A2:P" & Irow) Set rngCount = sht.[A3]: arrMain = rngMain.Value ReDim arrCount(1 To UBound(arrMain, 1), 1 To 1) For x = 1 To UBound(arrMain) If arrMain(x, 3) = "حامض" Then iCnt = iCnt + 1 arrCount(x - 5, 1) = iCnt End If Next x With rngCount.Resize(UBound(arrMain), 1) .Value = arrCount: .Font.Color = RGB(255, 0, 0): .Font.Bold = True: .Font.Size = 20 End With If WorksheetFunction.CountA(srcWS.Cells) = 0 Then Set OneRng = srcWS.Rows("1:4") For Each c In OneRng c.HorizontalAlignment = xlGeneral: c.VerticalAlignment = xlCenter: c.HorizontalAlignment = xlCenter c.RowHeight = 22: c.Font.Bold = True:: c.Font.Size = 14 Next c lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column ' + 1 Else lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column + 3 End If Dim Col_Widths As Range Set Col_Widths = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9)) Set Col_Border = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9), srcWS.Cells(1, lCol + 4)) rngMain.Copy With srcWS.Cells(5, lCol) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False Col_Widths.ColumnWidth = 18 j = Array(StDate, "", "", "", EnDate) With srcWS.Cells(1, lCol + 4).Offset(1).Resize(, 5) .Value = j: .Interior.Color = vbYellow: .Font.Color = RGB(255, 0, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) With srcWS.Cells(3, lCol + 12) .Value = "الأسبوع رقم :": .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) With srcWS.Cells(3, lCol + 13) .Value = st: .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) End With End With End With End With srcWS.Activate: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1: [B6].Select: ActiveWindow.Zoom = 95 a = Array("فواتير الأسبوع من", " ", CDate(desWS.[CV330]), " ", "إلى", " ", CDate(desWS.[DC330])) With srcWS.Cells(2, lCol + 3).Offset(1).Resize(, 7) .Value = a: .Interior.Color = RGB(255, 255, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) End With For Each xDate In srcWS.Range("D3", srcWS.Cells(3, Columns.Count).End(xlToLeft)) If IsDate(xDate.Value) Then xDate.NumberFormat = "yyyy-mm-dd" Next xDate sht.Delete MsgBox " تم ترحيل فواتير الأسبوع رقم :" & " " & st & " " & "بنجاح", vbInformation, "معلومات" desWS.Activate On Error GoTo 0 .DisplayAlerts = True .ScreenUpdating = True End With End If End Sub اما بالنسبة لكود حفظ الفواتير بصيغة PDF تم فصله وتعديله لتتمكن من حفظ او طباعة اي فواتير مرحلة مسبقا بعد استدعائها بشرط رقم الاسبوع بالشكل المطلوب مسبقا (كل فاتورة في ورقة مستقلة) Sub Choose_invoice_Print() Dim rng As Range, c As Range, Invoice As Range Dim Cpt&, Path As String, sFile As String Dim desWS As Worksheet: Set desWS = ActiveSheet Dim srcWS As Worksheet: Set srcWS = Sheets("فواتير الاسبوع"): Set WS = sheet1 On Error Resume Next If WorksheetFunction.CountA(srcWS.Cells) = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub Choose_invoice = InputBox(" المرجوا ادخال رقم الأسبوع " & "؟", " : حفظ وطباعة الفواتير الأسبوعية") If Choose_invoice = "" Then: Exit Sub FolderName = "Raed": Path = ThisWorkbook.Path & "\" & FolderName Set FindWeek = srcWS.Rows(3).Find(what:=Choose_invoice, LookIn:=xlValues, _ LookAt:=xlWhole) If Not FindWeek Is Nothing Then sFile = "الفواتير من" & " " & Format(FindWeek.Offset(0, -8).Text, "dd-mm-yyyy") _ & " " & "إلى" & " " & Format(FindWeek.Offset(0, -4).Text, "dd-mm-yyyy") Msg = MsgBox("؟" & " " & "PDF " & ":" & " حفظ فواتير الأسبوع" & " / " & FindWeek & " بصيغة", vbYesNo, sFile) If Msg <> vbYes Then Exit Sub Invoice = Choose_invoice.Value Application.ScreenUpdating = False For Each c In srcWS.Rows(3) If c.Value = Invoice Then Application.GoTo Reference:=srcWS.Range(FindWeek.Address) WS.Visible = xlSheetVisible: WS.Cells.Clear Cpt = ActiveCell.Column - 3 Irow = srcWS.Cells(srcWS.Rows.Count, Cpt).End(xlUp).Row Set rng = Range(ActiveCell.Offset(3, -12), ActiveCell.Offset(Irow - 2, 2)) rng.Copy With WS.Range("A" & Rows.Count).End(xlUp)(2) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Next f = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape For i = 1 To f Step 45 j = j + 1 WS.HPageBreaks.Add WS.Range("A" & i) Next i WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j If Dir(Path, vbDirectory) = "" Then MkDir Path nf = Dir(Path & "\" & sFile & "*") n = 0 Do While nf <> "" n = n + 1 nf = Dir Loop WS.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=Path & "\" & sFile & " (" & n + 1 & ")" & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' تفعيل الطباعة 'WS.PrintOut WS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Else MsgBox "رقم الأسبوع غير موجود على قاعدة البيانات", vbExclamation, "تم إلغاء الإجراء" End If On Error GoTo 0 desWS.Activate End Sub Book معدل 2.xls

راودتني هده الفكرة من قبل لا كن للاسف يصعب عليا فهم طريقة اشتغالك على الملف السؤال هو في حالة قمت بترحيل فواتير اسبوع معين هل يتم استخراج رقم الاسبوع من اخر تاريخ للفاتورة او فقط تسلسل بعدد الاسابيع المرحلة مثال لنفترض انه تم ترحيل مثلا اول فاتورة من تاريخ 2024/04/05 الى 2024/04/11 ماهو رقم الاسبوع المتوقع هل 1 او 15

اسف اخي على التاخير في الرد بسبب ظروف العمل وضيق الوقت لدي تفضل جرب هدا حاولت تعديل الاكواد قدر المستطاع للحصول على نفس الشكل المطلوب اتمنى ان يلبي طلبك Book معدل.xls

بكل سرور اخي @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