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

تفضل استاذ @زيد يحي محاولتي حسب مافهمت . ادرس المرفق جيداً وأي استفسار أنا حاضر . اليك المرفق . Staff custody.rar

طيب مشاركة مع اخوانى الكرام واساتذتى الافاضل بعد التعديلات على الاكواد #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr #Else Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If #Else Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If Private Const GW_CHILDREN As Long = 5 Private Const WM_COMMAND As Long = &H111 Private Sub Btn_Hide_Click() Dim toggleDesktopCommand As Long Dim hWnd As LongPtr toggleDesktopCommand = &H7402 hWnd = FindWindow("Progman", "Program Manager") If hWnd <> 0 Then hWnd = GetWindow(hWnd, GW_CHILDREN) If hWnd <> 0 Then SendMessage hWnd, WM_COMMAND, toggleDesktopCommand, ByVal 0& If Btn_Hide.Caption = "Hide Icon" Then Me.Btn_Hide.Caption = "Show Icon" Me.Caption = " Desktop Icon Hide" Else Me.Btn_Hide.Caption = "Hide Icon" Me.Caption = " Desktop Icon Show" End If Else MsgBox "Failed to find child window of Program.", vbExclamation End If Else MsgBox "Failed to find Program window.", vbExclamation End If End Sub Private Sub Form_Load() Me.Caption = "" End Sub Hide Icon Desktop.accdb

أخي @TQTHAMI ، للمحاولة جرب هذا المرفق والكود :- Option Compare Database Option Explicit #If Win64 Then Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long #Else Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long #End If Private Const SW_HIDE As Long = 0 Private Const SW_SHOW As Long = 5 Public Sub HideDesktopIcons() Dim hWndProgMan As LongPtr Dim hWndSHELLDLL_DefView As LongPtr Dim hWndSysListView32 As LongPtr hWndProgMan = FindWindow("Progman", vbNullString) hWndSHELLDLL_DefView = FindWindowEx(hWndProgMan, 0, "SHELLDLL_DefView", vbNullString) hWndSysListView32 = FindWindowEx(hWndSHELLDLL_DefView, 0, "SysListView32", "FolderView") ShowWindow hWndProgMan, SW_HIDE ShowWindow hWndSHELLDLL_DefView, SW_HIDE ShowWindow hWndSysListView32, SW_HIDE End Sub Public Sub ShowDesktopIcons() Dim hWndProgMan As LongPtr Dim hWndSHELLDLL_DefView As LongPtr Dim hWndSysListView32 As LongPtr hWndProgMan = FindWindow("Progman", vbNullString) hWndSHELLDLL_DefView = FindWindowEx(hWndProgMan, 0, "SHELLDLL_DefView", vbNullString) hWndSysListView32 = FindWindowEx(hWndSHELLDLL_DefView, 0, "SysListView32", "FolderView") ShowWindow hWndProgMan, SW_SHOW ShowWindow hWndSHELLDLL_DefView, SW_SHOW ShowWindow hWndSysListView32, SW_SHOW End Sub Private Sub Btn_Hide_Click() If Btn_Hide.Caption = "Hide Icon" Then HideDesktopIcons Me.Btn_Hide.Caption = "Show Icon" Me.Caption = " Desktop Icone Hide" Else ShowDesktopIcons Me.Btn_Hide.Caption = "Hide Icon" Me.Caption = " Desktop Icone Show" End If End Sub Hide Icon Desktop - 2.accdb

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

اخي @Foksh تم حل المشكلة عن طريق تغير تنسيق الاخراج الى xlsx جزاك الله خير وشاكر لك اهتمامك

هذا الماكرو يستبدل مجموعة كلمات، ويضع مكانها كلمة واحدة. يعني يمكن أن تضع في خانة البحث: محمد ، أحمد ، إبراهيم وفي خانة الاستبدال: عمر وستحول كل المواضع التي فيها (محمد ، عمر ، إبراهيم) إلى (عمر) ' ' استبدال مجموعة كلمة متفرقة بكلمة واحد ' ' Dim xFind As String Dim xReplace As String Dim xFindArr, xReplaceArr Dim i As Long xFind = InputBox("أدخل هنا مجموعةالكلمات التي تريد استبدالها، مفصولة بفاصلة: ", "الكلمات المطلوب استبدالها") xReplace = InputBox(":أدخل الكلمة التي تريد استبدالها مكان الكلمات السابقة ", "الكلمة الجديدة") xFindArr = Split(xFind, "،") For i = 0 To UBound(xFindArr) With Selection.Find .ClearFormatting .Replacement.ClearFormatting .Text = xFindArr(i) .Replacement.Text = xReplace .Format = False .MatchWholeWord = False End With Selection.Find.ClearFormatting ' لو أردت حذف التمييز، فاحذف هذا السطر، والثلاثة التالية له Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True Options.DefaultHighlightColorIndex = wdBrightGreen Selection.Find.Execute Replace:=wdReplaceAll Next Application.ScreenUpdating = True Beep End Sub

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل Nationalities جدول الجنسيات.xlsx

الأجزاء كاملة قائمة المشاريع وتافيديوهات على القناة

هذا يعمل عندي بكفاءة 👍🏻

غريب ، هذا هو كود الأستاذ @محمد احمد لطفى ، من جهازي ما هو اصدار الويندوز والأوفيس لديك ؟ 20240506_170555.zip

أستخدم هذا الكود On Error GoTo Err_Form_Open ChangeProperty "AllowBypassKey", 1, 0 fAccessWindow acHide, False, False With New Access.Application Dim strDbName As String strDbName = CurrentProject.Path & "\Start.accdb" .UserControl = True .RunCommand acCmdAppMaximize DoCmd.RunCommand acCmdAppMaximize .OpenCurrentDatabase strDbName, , "K@serwww$0ficena%9o6" End With Application.Quit Exit_Form_Open: Exit Sub Err_Form_Open: MsgBox "خطأً " & " " & vbCr & vbCr & " تم حذف البرنامج أو تم أعادة تسميته ", 0 + 16 + 1572864, "بدأ التشغيل" Application.Quit Resume Exit_Form_Open ::بالتوفيق:: إذا كنت ترى أن هذه المشاركة مفيدة فلا تنسى التقييم