نجوم المشاركات

تفضل رصيد بنك الكويت.xlsx

هل جربت تنصيب اوفيس 2019 أو 2016 ؟

ا السلام عليكم ورحمة الله و بركاته طلبك هنا http://www.officena.net/ib/index.php?showtopic=40007

تفضل استاذ @TAMER AGOOR محاولتي حسب مافهمت .اليك الشرح والمرفق .ووافني بالرد . قاعده بيانات للتجارب-1.rar

بناءً عليه فإن المشكلة في تحديثات الأوفيس365 لديك. 🤗 سؤال جميل ، وأعتقد أنه ممكن ذلك

اسف اخي على التاخير في الرد لاكنني عند الاشتغال على الملف ومراجعة الاكواد لاحظت بعد الهفوات التي لم انتبه اليها من قبل 😱 ربما انت لم تلاحظها لاكنها حتما سوف تسبب لك اخطاء بعد تحديث البيانات وخاصة عند اظافة بيانات جديدة لم تكن موجودة مسبقا على الملف ...... (رحم الله من عمل عملا فأتقنه) تفضل استبدل كود التوزيع بالكود التالي بعد تنقيحه بشكل افضل وادق 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

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

الشكر لله اخي الحمد لله الذي بنعمته تتم الصالحات

تفضل لان الخليه f3 بها تاريخ ظهر لك هذا الخطأ sNewFilePath = ThisWorkbook.Path & "\" & Replace(Range("F3").text, "/", "-") & ".pdf"

السلام عليكم ورحمة الله وبركاته وبها نبدأ عدل السطر الى sNewFilePath = ThisWorkbook.Path & "\" & Range("F3").text & ".pdf"

وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل نموذج ادخال بيانات الحجاج داخل الشيت.xlsm

هذا موضوع اخر اخي كمال يرجي فتح موضوع اخر بالطلب الجديد

وعليكم السلام ورحمة الله وبركاته فى كود Compare() عدل الحلقة التكرارية For j = 5 To lr الى For j = 27 To lr