محمد هشام.

وعليكم السلام ورحمة الله نعالى وبركاته جرب هل هدا ما تقصده Textbox يحتوي علي نص موجود..xlsm

يسعدنا حصولك على النتيجة المطلوبة لاكن للفائدة فقط لا غير . من الممكن تبسيط الكود لاكن هناك احتمالات واردة ربما لم تقم بتجربتها مثلا كالبحث عن قيمة فريدة او رقم يتضمن قيمة عشرية الكود الخاص بي تم انشاءه لتطابق القيم ليس للبحث بالتشابه هدا لانك طلبت البحث بجميع الاعمدة عن قيمة معينة او ربما لم استوعب طلبك جيدا .لقد فكرت مسبقا في اقتراح استادنا الغالي @حسونة حسين لاكن للاسف يعطي اخطاء جرب ادخال قيمة غير مكررة او تاريخ غير مكرر والبحث عنها او البحث عن رقم مثلا 3.530 ستلاحظ انه تم اظهار رسالة عدم تواجده . او تكراره في عدة اعمدة رغم وجوده مرة واحدة فقط على الملف بالتوفيق.......... جديد (1).xlsm

جرب هذا سيتم نسخ الملف الى مصنف جديد بصيغة xlsx . في نفس مسار المصنف المفتوح TEST WORD 2.rar

لا افهم مادا تقصد لاكن طلبك كان في في تحديد اخر رقم ضمن المسلسل وهو على ملفك الرقم 78 وهدا ما ينفده الكود شيت الصف السادس ترم ثان.pdf

Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("word") Dim ar(1 To 7) Dim c As Integer Dim cnt As Integer cnt = LBound(ar()) ' قم بتعديل عرض الاعمدة بما يناسبك ar(1) = 10: ar(4) = 28: ar(7) = 85: ar(5) = 28: ar(6) = 35: ar(2) = 14: ar(3) = 68 On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WS.Cells.Clear For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, _ 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 0 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing lr = WS.Columns("A:G").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 For Each j In WS.Range("G2:G" & lr) WS.Hyperlinks.Add j, j Next j WS.Rows(1).Interior.ColorIndex = 45 For cnt = LBound(ar()) To UBound(ar()) Columns(cnt).ColumnWidth = ar(cnt) Next cnt Set rngCell = WS.Range("A1 :g" & lr) For Each k In rngCell.Rows If WorksheetFunction.CountA(k) > 0 Then k.Borders.ColorIndex = 5 'c.Borders.LineStyle = xlContinuous Next With WS.Range("a2:a" & WS.Cells(Rows.Count, "b").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With End Sub https://streamable.com/xdlk5v TEST WORD.rar

للتوضيح فقط لتجاوز حد 10 أعمدة لخاصية AddItem لعنصر التحكم، يتعين عليك استخدام إما خاصية القائمة المضافة من محتويات صفيف (يمكن أن تكون Range.Value) أو خاصية Rowsource المتصلة بنطاق ربما لو كان البحث في عمود محدد مسبقا ستكون الامور اسهل بكثير وفقًا لمتطلباتك.و لشكل الملف لديك يجب أن تفعل المصفوفة ثنائية الأبعاد ما تريد، ولاكن أثناء قيامك بالبحث في أوراق متعددة، ستحتاج إلى تحديد حجم المصفوفة بشكل صحيح عن طريق حساب إجمالي عدد التطابقات عبر جميع الأوراق أولاً قبل تعبئتها. صراحة ليس لي الكثير من الوقت لقضائه في هذا الأمر وتم اختباره فقط على بياناتك المرفقة - وبالتالي فإن محاولاتي لتحديث الكود الخاص بك قد تحتاج إلى بعض التعديل/ إعادة التفكير ولكن جرب ما إذا كان هذا سيفعل ما تريد Private Sub CommandButton1_Click() Dim sh As Worksheet Dim Cpt As String, SearchAddress As String Dim Found As Range, wsRangeArr() As Range Dim CountAllMatches As Long, CountMatch As Long Dim i As Long, r As Long, c As Long Dim Search As Variant, SearchRange As Variant Dim SearchSheetsArr As Variant, CopyArr() As Variant Const ColCount As Long = 12 SearchAddress = "A:J" SearchSheetsArr = Array("عين غزال", "الجبيهة", "أربد", "الزرقاء") '---------------------------------------------------------------------------------------------------------- Search = Me.TextBox1.Value If Len(Search) = 0 Then Exit Sub If IsDate(Search) Then Search = DateValue(Search): LookIn = xlFormulas Else LookIn = xlValues For Each sh In ThisWorkbook.Worksheets(SearchSheetsArr) CountMatch = Application.CountIf(sh.Range(SearchAddress), Search) If CountMatch > 0 Then i = i + 1: ReDim Preserve wsRangeArr(1 To i): Set wsRangeArr(i) = sh.Range(SearchAddress) 'العدد الإجمالي لجميع التطابقات في النطاقات CountAllMatches = CountAllMatches + CountMatch End If CountMatch = 0 Next sh On Error Resume Next If CountAllMatches > 0 Then ReDim CopyArr(1 To CountAllMatches, 1 To ColCount) 'أوراق البحث / النطاقات مع التطابقات r = 0 For Each SearchRange In wsRangeArr 'نطاق البحث Set Found = SearchRange.Find(Search, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False) Cpt = Found.Address Do 'ملء عناصر المصفوفة r = r + 1 For c = 1 To UBound(CopyArr, xlColumns) - 2 CopyArr(r, c) = SearchRange.Cells(Found.Row, c).Text Next c CopyArr(r, c) = Found.Address CopyArr(r, c + 1) = SearchRange.Parent.Name Set Found = SearchRange.FindNext(Found) Loop While Found.Address <> Cpt Set Found = Nothing Next SearchRange End If 'ملء مربع القائمة أو الإبلاغ عن عدم وجود تطابقات With Me.ListBox1 .ColumnCount = IIf(CountAllMatches > 0, ColCount, 1) .List = IIf(CountAllMatches > 0, CopyArr, Array("ما تحاول البحث عنه غير موجود في الاسواق")) .Font.Size = IIf(CountAllMatches > 0, 9, 24) .TextAlign = IIf(CountAllMatches > 0, fmTextAlignLeft, fmTextAlignCenter) End With End Sub Private Sub TextBox1_Change() If Len(Me.TextBox1) = 0 Then Me.ListBox1.Clear End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.TextBox1 = "": Me.ListBox1.Clear End Sub جديد v2.xlsm

Sub PDF_شيت_ترم_2() Dim FSO As Object Dim S(1) As String Dim sNewFilePath As String Dim Row As Long Set FSO = CreateObject("Scripting.FileSystemObject") S(0) = ThisWorkbook.FullName If FSO.FileExists(S(0)) Then S(1) = FSO.GetExtensionName(S(0)) If S(1) <> "" Then S(1) = "." & S(1) Set WS = ActiveSheet lastRow = WS.Columns("A:A").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With WS.PageSetup .PrintArea = "$A$3:$CH$" & lastRow End With sNewFilePath = ThisWorkbook.Path & "\شيت الصف السادس ترم ثان.pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Else MsgBox "لم يتم حفظ الملف ..يوجد خطأ ما " End If Sheets("شيت2").Activate Set FSO = Nothing ' mainy m = MsgBox("تم تصدير الشيت خارج الشيت بإسم شيت الصف السادس ترم ثان" & vbNewLine _ & "هذا الملف موجود فى نفس مكان برنامج الكنترول شيت", _ vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal + vbMsgBoxRight, _ "تم تصدير شيت صف السادس ترم 2 بصيغة pdf.") End Sub

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