والله حضرتك مهندس محترم وشغلك يقدر بجد ربنا يفتح عليك ويكرمك من وسع ❤

مش بيظهر شاشة البرنامج يا هندسة الmacro مش بيشتغل

الله ينور يا هندسة بالتوفيق

الكود المستخدم فى الفيديو Sub UnhideRowsWithData() Dim ws As Worksheet Dim row As Long Dim lastCol As Long Set ws = ActiveSheet lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column For row = 1 To ws.Rows.Count If ws.Rows(row).Hidden = True Then If Application.WorksheetFunction.CountA(ws.Range(ws.Cells(row, 1), ws.Cells(row, lastCol))) > 0 Then ws.Rows(row).Hidden = False End If End If Next row End Sub

جزاك الله خيرا يا هندسه ❤

'الكودالمستخدم فى الفيديو Sub SearchTable() Dim ws As Worksheet Dim searchText As Variant Dim searchColumn As Range Dim table As ListObject Dim colIndex As Integer Dim visibleRows As Long Dim searchPattern As String Dim isNumber As Boolean Set ws = ActiveSheet searchText = InputBox("ما هو النص أو الرقم الذي تبحث عنه:") If searchText = "" Then Exit Sub End If On Error Resume Next Set searchColumn = Application.InputBox("اختار العمود الذي تبحث فيه:", Type:=8) On Error GoTo 0 If searchColumn Is Nothing Then Exit Sub End If If Intersect(searchColumn, ws.UsedRange.Columns) Is Nothing Then MsgBox "العمود المحدد ليس ضمن النطاق المستخدم في الورقة. تم إلغاء العملية.", vbExclamation Exit Sub End If colIndex = searchColumn.Column ' تحديد نمط البحث الجزئي searchPattern = "*" & searchText & "*" isNumber = IsNumeric(searchText) On Error Resume Next Set table = ws.ListObjects(1) On Error GoTo 0 Application.ScreenUpdating = False If Not table Is Nothing Then If isNumber Then table.Range.AutoFilter Field:=colIndex, Criteria1:="=" & searchText, Operator:=xlOr, Criteria2:=searchPattern, Operator:=xlFilterValues Else table.Range.AutoFilter Field:=colIndex, Criteria1:=searchPattern, Operator:=xlFilterValues End If visibleRows = Application.WorksheetFunction.Subtotal(103, table.ListColumns(colIndex).DataBodyRange) If visibleRows = 0 Then MsgBox "لم يتم العثور على بيانات تطابق النص أو الرقم المدخل.", vbInformation table.AutoFilter.ShowAllData End If Else ws.AutoFilterMode = False ' إيقاف أي فلاتر موجودة If isNumber Then ws.Range(ws.Cells(1, colIndex), ws.Cells(ws.Rows.Count, colIndex)).AutoFilter Field:=1, Criteria1:="=" & searchText, Operator:=xlOr, Criteria2:=searchPattern Else ws.Range(ws.Cells(1, colIndex), ws.Cells(ws.Rows.Count, colIndex)).AutoFilter Field:=1, Criteria1:=searchPattern End If visibleRows = ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1 ' خصم 1 لصف العنوان If visibleRows = 0 Then MsgBox "لم يتم العثور على بيانات تطابق النص أو الرقم المدخل.", vbInformation ws.AutoFilterMode = False End If End If Application.ScreenUpdating = True End Sub

بالتوفيق دايما يا بشمهندس

الاسطورة اللي مشرفنا ❤❤❤ حبيبي م أسامة

*الكود المستخدم فى الفيديو Sub AddMultipleFilesToSheet() Dim ws As Worksheet Dim selectedCell As Range Dim fileDialog As fileDialog Dim filePath As Variant Dim fileName As String Dim i As Integer Set ws = ActiveSheet Set selectedCell = Application.Selection Set fileDialog = Application.fileDialog(msoFileDialogFilePicker) With fileDialog .AllowMultiSelect = True .Title = "Select Files" .Filters.Clear .Filters.Add "All Files", "*.*" If .Show = -1 Then i = selectedCell.Row For Each filePath In .SelectedItems fileName = Dir(filePath) With ws .Hyperlinks.Add Anchor:=.Cells(i, selectedCell.Column), Address:=filePath, TextToDisplay:=fileName End With i = i + 1 Next filePath End If End With End Sub

*الكود المستخدم فى الفيديو Sub RenameFiles() Dim ws As Worksheet Dim selectedCells As Range Dim cell As Range Dim fso As Object Dim fd As FileDialog Dim selectedFiles As Variant Dim i As Integer Dim fileCount As Integer Dim oldFileName As String Dim fileExtension As String Dim newFileName As String Dim cellCount As Integer Dim hasEmptyCells As Boolean Dim baseName As String Dim newNameWithoutCounter As String Dim nameDict As Object Dim duplicateNames As Boolean Dim colorDict As Object Dim colorIndex As Integer Dim usedColors As Object Dim color As Long ' تعيين الورقة النشطة Set ws = ActiveSheet ' التحقق من أن التحديد هو نطاق If TypeName(Selection) <> "Range" Then MsgBox "يرجى تحديد نطاق من الخلايا التي تحتوي على الأسماء الجديدة للملفات." Exit Sub End If Set selectedCells = Selection ' التحقق من وجود خلايا فارغة في التحديد cellCount = selectedCells.Cells.Count hasEmptyCells = False For Each cell In selectedCells If cell.Value = "" Then hasEmptyCells = True Exit For End If Next cell If hasEmptyCells Then MsgBox "التحديد يحتوي على خلايا فارغة. يرجى التأكد من أن جميع الخلايا تحتوي على قيمة." Exit Sub End If ' تهيئة كائن نظام الملفات والقاموس لتتبع الأسماء Set fso = CreateObject("Scripting.FileSystemObject") Set nameDict = CreateObject("Scripting.Dictionary") Set colorDict = CreateObject("Scripting.Dictionary") Set usedColors = CreateObject("Scripting.Dictionary") ' التحقق من وجود أسماء مكررة وتلوين الخلايا المكررة duplicateNames = False colorIndex = 3 ' بداية مؤشر الألوان (نبدأ من 3 لأن 1 و 2 محفوظين للألوان الأحمر والأصفر) For Each cell In selectedCells baseName = cell.Value If nameDict.Exists(baseName) Then duplicateNames = True If colorDict.Exists(baseName) Then color = colorDict(baseName) Else ' تحديد لون جديد غير مستخدم Do colorIndex = colorIndex + 1 color = RGB((colorIndex * 20) Mod 128, (colorIndex * 40) Mod 128, (colorIndex * 60) Mod 128) Loop While usedColors.Exists(color) ' حفظ اللون كونه مستخدم usedColors.Add color, 1 colorDict.Add baseName, color End If cell.Interior.Color = color ' تلوين الخلايا المكررة بلون مختلف Else nameDict.Add baseName, 1 cell.Interior.ColorIndex = xlNone ' إزالة التلوين من الخلايا غير المكررة End If Next cell ' إذا كانت هناك أسماء مكررة، عرض رسالة وإنهاء If duplicateNames Then MsgBox "يوجد أسماء مكررة في التحديد يرجى تحديث الأسماء قبل المتابعة" Exit Sub End If ' فتح مربع الحوار لتحديد الملفات Set fd = Application.FileDialog(msoFileDialogFilePicker) fd.Title = "اختر الملفات التي تريد إعادة تسميتها" fd.AllowMultiSelect = True fd.Filters.Clear fd.Filters.Add "All Files", "*.*" ' عرض مربع الحوار وتخزين الملفات المختارة If fd.Show = -1 Then fileCount = fd.SelectedItems.Count ReDim selectedFiles(1 To fileCount) For i = 1 To fileCount selectedFiles(i) = fd.SelectedItems(i) Next i Else Exit Sub End If ' التحقق من أن عدد الملفات المختارة يطابق عدد الخلايا في التحديد If fileCount <> cellCount Then MsgBox "عدد الملفات المختارة لا يطابق عدد الخلايا في التحديد." Exit Sub End If ' إعادة تسمية الملفات i = 1 For Each cell In selectedCells baseName = cell.Value oldFileName = selectedFiles(i) fileExtension = "." & fso.GetExtensionName(oldFileName) newFileName = fso.BuildPath(fso.GetParentFolderName(oldFileName), baseName & fileExtension) ' محاولة إعادة تسمية الملف On Error Resume Next fso.MoveFile oldFileName, newFileName If Err.Number <> 0 Then MsgBox "خطأ في إعادة تسمية الملف: " & Err.Description Err.Clear End If On Error GoTo 0 i = i + 1 Next cell 'MsgBox "تمت عملية إعادة تسمية الملفات بنجاح!" ' تنظيف Set fso = Nothing Set fd = Nothing Set nameDict = Nothing Set colorDict = Nothing Set usedColors = Nothing End Sub

لو حابب اعمل العكس يا هندسه يعني لو عندي بقي اسامي موحوده في خلايا الاكسيل وعايز اسمي بيها مجموعه ملفات بنفس الترتيب

Sub AddMultipleFileNamesToSheet() Dim ws As Worksheet Dim selectedCell As Range Dim fileDialog As fileDialog Dim filePath As Variant Dim fileName As String Dim i As Integer Set ws = ActiveSheet Set selectedCell = Application.Selection Set fileDialog = Application.fileDialog(msoFileDialogFilePicker) With fileDialog .AllowMultiSelect = True .Title = "Select Files" .Filters.Clear .Filters.Add "All Files", "*.*" If .Show = -1 Then i = selectedCell.Row For Each filePath In .SelectedItems fileName = Dir(filePath) ws.Cells(i, selectedCell.Column).Value = fileName i = i + 1 Next filePath End If End With End Sub

جزاك الله خيرا

اين شيت الاكسل

' كود نسخ الشيتات داخل شيت واحد حسب اسم الشيت الذى تريد نسخة وحسب عدد النسخ الذى تريد نسخها Sub copysheets() Dim sheetName As String Dim numberofcopies As Variant Dim ws As Worksheet Dim copy As Integer If Worksheets.Count = 1 Then sheetName = Worksheets(1).Name Else sheetName = InputBox("ماهو اسم الشيت الذى تريد نسخة") If sheetName = "" Then Exit Sub End If End If numberofcopies = InputBox("كم عدد النسخ المطلوبة") If numberofcopies = "" Then Exit Sub End If If Not IsNumeric(numberofcopies) Or numberofcopies <= 0 Then MsgBox "الرجاء إدخال عدد صحيح موجب للنسخ" Exit Sub End If On Error Resume Next Set ws = Worksheets(sheetName) On Error GoTo 0 If ws Is Nothing Then MsgBox " " & sheetName & " غير موجود." Exit Sub End If For copy = 1 To numberofcopies ws.Copy After:=ws Next copy End Sub

بالتوفيق دايما يا بشمهندس

Sub split_excel_sheets() Dim iPath As String Dim newFolderPath As String Dim folderExists As Boolean Dim folderIndex As Integer Dim fileExtension As String Dim fileFormat As Long Dim ws As Worksheet On Error GoTo ErrorHandler ' إضافة معالجة الأخطاء iPath = Application.ActiveWorkbook.Path ' تحديد امتداد الملف الحالي وتعيين التنسيق المناسب If Right(Application.ActiveWorkbook.Name, 5) = ".xlsm" Then fileExtension = ".xlsm" fileFormat = 52 ' صيغة ملف xlsm Else fileExtension = ".xlsx" fileFormat = 51 ' صيغة ملف xlsx End If newFolderPath = iPath & "\SplitSheets" ' التحقق من وجود المجلد وتحديد اسم المجلد الجديد folderExists = Dir(newFolderPath, vbDirectory) <> "" folderIndex = 0 Do While folderExists folderIndex = folderIndex + 1 newFolderPath = iPath & "\SplitSheets" & folderIndex folderExists = Dir(newFolderPath, vbDirectory) <> "" Loop ' إنشاء المجلد الجديد MkDir newFolderPath If ActiveWorkbook.Sheets.Count > 1 Then Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In ActiveWorkbook.Sheets If ws.Visible = xlSheetVisible Then ' التحقق مما إذا كان الشيت مرئيًا ws.Copy ' حفظ المصنف الجديد With ActiveWorkbook .SaveAs Filename:=newFolderPath & "\" & ws.Name & fileExtension, fileFormat:=fileFormat .Close False End With End If Next ws Application.DisplayAlerts = True Application.ScreenUpdating = True Else MsgBox "لا يوجد إلا ورقة واحدة في هذا الشيت." End If Exit Sub ' الخروج من الإجراء قبل التعامل مع الخطأ ErrorHandler: ' التعامل مع الأخطاء هنا MsgBox "حدث خطأ: " & Err.Description, vbExclamation Resume Next ' الانتقال إلى السطر التالي بعد الخطأ End Sub

جزاكم الله خيرا م أسامه مجهود مميز جدا

Sub MergeExcelSheetsIntoActiveWorkbook() Dim FileDialog As FileDialog Dim SelectedFiles As FileDialogSelectedItems Dim wbSource As Workbook Dim wsSource As Worksheet Dim wbDest As Workbook ' Initialize the file dialog to select multiple files Set FileDialog = Application.FileDialog(msoFileDialogFilePicker) FileDialog.AllowMultiSelect = True FileDialog.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls" ' Show the file dialog If FileDialog.Show = -1 Then Set SelectedFiles = FileDialog.SelectedItems Else MsgBox "No files selected." Exit Sub End If ' Set the active workbook as the destination workbook Set wbDest = ActiveWorkbook Application.ScreenUpdating = False Application.DisplayAlerts = False ' Loop through each selected file For Each FilePath In SelectedFiles Set wbSource = Workbooks.Open(FilePath) ' Loop through each sheet in the source workbook For Each wsSource In wbSource.Sheets ' Copy the sheet to the destination workbook wsSource.copy After:=wbDest.Sheets(wbDest.Sheets.Count) Next wsSource ' Close the source workbook without saving wbSource.Close False Next FilePath Application.DisplayAlerts = True Application.ScreenUpdating = True 'MsgBox "All sheets have been merged into the active workbook." End Sub

جزاكم الله خيرا بالتوفيق دايما يا هندسه

جزاكم الله خيرا لو سمحت يا هندسه لما بدخل الكود العربي بيبوط بيكون مكتوب زي كدا (ReMark = "ظٹطھط¨ظ‚ظ‰ ظ„ظƒظ… ") اي حلها

ممكن ليسب أو الاضافه أو الرابط

يا باشمهندس انت شغال بإضافة ولا بليسب انت ازاي رابط بين الأوفيس والاتوكاد

بالتوفيق دايما يا بشمهندس

مش شغال معايا البرنامج شيت اكسيل عادي

' كود التفقيط بعملة الريال السعودى المستخدم فى الفيديو Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim Myno As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim I As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1 ReMark = "يتبقى لكم " Else ReMark = "فقط " End If If TheNo = 0 Then NoToTxt = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "واحد" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "أربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Format(TheNo, "000000000000.00") I = 0 Do While I < 15 If I < 12 Then Myno = Mid$(GetNo, I + 1, 3) Else Myno = "0" + Mid$(GetNo, I + 2, 2) End If If (Mid$(Myno, 1, 3)) > 0 Then RdNo = Mid$(Myno, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(Myno, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(Myno, 2, 1) My10 = MyArry2(RdNo) If Mid$(Myno, 2, 2) = 11 Then My11 = "إحدى عشر" If Mid$(Myno, 2, 2) = 12 Then My12 = "إثنى عشر" If Mid$(Myno, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12 End If If (I = 0) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (I = 3) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (I = 6) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (I = 9) And (GetTxt <> "") Then MyHun = GetTxt If (I = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If I = I + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function Sub ConvertNumberToText() Dim NumberCell As Range Dim TextCell As Range Dim TheNumber As Double Dim ResultText As String ' اطلب من المستخدم تحديد الخلية التي تحتوي على الرقم On Error Resume Next Set NumberCell = Application.InputBox("حدد الخلية التي تحتوي على الرقم:", Type:=8) On Error GoTo 0 ' تحقق من أن التحديد صالح If NumberCell Is Nothing Then 'MsgBox "لم يتم تحديد أي خلية.", vbExclamation Exit Sub End If ' احصل على الرقم من الخلية المحددة TheNumber = NumberCell.Value ' حول الرقم إلى نص ResultText = NoToTxt(TheNumber, "ريال", "هللة") ' اطلب من المستخدم تحديد الخلية التي تريد كتابة النص فيها On Error Resume Next Set TextCell = Application.InputBox("حدد الخلية التي تريد كتابة النص فيها:", Type:=8) On Error GoTo 0 ' تحقق من أن التحديد صالح If TextCell Is Nothing Then 'MsgBox "لم يتم تحديد أي خلية.", vbExclamation Exit Sub End If ' اكتب النص في الخلية المحددة TextCell.Value = ResultText ' MsgBox "تم تحويل الرقم إلى نص.", vbInformation End Sub

بالتوفيق دائما وأبدا

تسلم يا هندسه جزاك الله خير الجزاء ❤

بالتوفيق دايما يا بشمهندس

kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=lrPzOrO0WEiQ4LPK الاصدار النهائي لملف اكسل حصر الحديد مع رسم اشكال الحديد وكتابة الاطوال على اشكال الحديد

kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=lrPzOrO0WEiQ4LPK الاصدار النهائي لملف اكسل حصر الحديد مع رسم اشكال الحديد وكتابة الاطوال على اشكال الحديد

kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=lrPzOrO0WEiQ4LPK الاصدار النهائي لملف اكسل حصر الحديد مع رسم اشكال الحديد وكتابة الاطوال على اشكال الحديد

ربنا يباركلك يا هندسة من افضل للافضل ان شاءالله

ما شاء الله تبارك الله .. شغل عالي يا هندسه .. تسلم ايدك

للاسف مش شغال في في ادخال البيانات

جزاك الله خيرا يا هندسه ❤

بجد عااااااااش اوي يا هندسة و دائما موفق كدا و من نجاح ل نجاح دائما يارب 🔥🔥🙏💙 و بانتظار القادم اقوي باذن الله ❤️

facebook.com/groups/1344832723089730 يشرفنى انضمامك لجروب القناة

نزلته بس مايشتغلش

اصلي

انت جامد جدا

بارك الله فيك ياباشمهندس، تواصلت امس معك فى الخاص ، وماقصرت .. حفظكم الله بحفظه

سلام عليكم الشيت هايل بصراحة الله ينور ياهندسة ( بس عندي مشكلة معينة فى الشيت اني عايز اضيف شكل معين مش موجود فى الاشكال المتاحة ؟؟؟؟) ياريت ترد علية فى اقرب فرصة

ممتاز جزاك الله خيراً يا هندسة

تسلم ايدك يا هندسة والله عااااااااش 👌🔥❤️

facebook.com/groups/1344832723089730 يشرفنى انضمامك لجروب القناة

كيف اقدر احصل على هذه الاضافه

كويس جدا

نزلته بس ما يعملش

السلام عليكم كويس جدا