والله حضرتك مهندس محترم وشغلك يقدر بجد ربنا يفتح عليك ويكرمك من وسع ❤
@QuantitiesSurveying6 күн бұрын
الله يكرمك يا هندسة ربنا يعزك ويرزقنا جميعا ❤
@user-fc7sg6mp9j7 күн бұрын
مش بيظهر شاشة البرنامج يا هندسة الmacro مش بيشتغل
@QuantitiesSurveying7 күн бұрын
@@user-fc7sg6mp9j تواصل معايا يا هندسة على لواتس +966560261116 والإصدار النهائي بفلوس ومجانى لغير المقتدر ام الاصدار التالت مجانى تقدر تستخدمة رابط التحميل هتلاقية اسفل الفيديو
@ahmedeloraby6378 күн бұрын
الله ينور يا هندسة بالتوفيق
@QuantitiesSurveying11 күн бұрын
الكود المستخدم فى الفيديو 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
@mohamedeid199320 күн бұрын
جزاك الله خيرا يا هندسه ❤
@QuantitiesSurveying20 күн бұрын
وجزاكم بالمثل يا هندسة ❤
@QuantitiesSurveying20 күн бұрын
'الكودالمستخدم فى الفيديو 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
@asmaaorabi304123 күн бұрын
بالتوفيق دايما يا بشمهندس
@mohamedeid199323 күн бұрын
الاسطورة اللي مشرفنا ❤❤❤ حبيبي م أسامة
@QuantitiesSurveying23 күн бұрын
*الكود المستخدم فى الفيديو 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
@QuantitiesSurveying26 күн бұрын
*الكود المستخدم فى الفيديو 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
@mohamedeid1993Ай бұрын
لو حابب اعمل العكس يا هندسه يعني لو عندي بقي اسامي موحوده في خلايا الاكسيل وعايز اسمي بيها مجموعه ملفات بنفس الترتيب
@QuantitiesSurveyingАй бұрын
@@mohamedeid1993 حاضر يا هندسة بسيطة ان شاء الله هابقى اعمل فيديو مخصوص للحوار دة
@QuantitiesSurveyingАй бұрын
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
@mohamedeid1993Ай бұрын
الله ينور عليك يا هندسه ❤
@QuantitiesSurveyingАй бұрын
@@mohamedeid1993 🌺🌺
@almahbobsamy8660Ай бұрын
جزاك الله خيرا
@QuantitiesSurveyingАй бұрын
@@almahbobsamy8660 وجزاكم بالمثل بالتوفيق ان شاء الله
@user-oz2fd4qe7dАй бұрын
اين شيت الاكسل
@QuantitiesSurveyingАй бұрын
@@user-oz2fd4qe7d رابط شيت الاكسل موجود اسفل وصف الفيديو يا هندسة
@QuantitiesSurveyingАй бұрын
' كود نسخ الشيتات داخل شيت واحد حسب اسم الشيت الذى تريد نسخة وحسب عدد النسخ الذى تريد نسخها 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
@asmaaorabi3041Ай бұрын
بالتوفيق دايما يا بشمهندس
@QuantitiesSurveyingАй бұрын
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
@waelmahmoud2810Ай бұрын
جزاكم الله خيرا م أسامه مجهود مميز جدا
@QuantitiesSurveyingАй бұрын
وجزاكم بالمثل يا مهندس وائل بالتوفيق ان شاء الله
@QuantitiesSurveyingАй бұрын
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
@waelmahmoud2810Ай бұрын
جزاكم الله خيرا بالتوفيق دايما يا هندسه
@waelmahmoud2810Ай бұрын
جزاكم الله خيرا لو سمحت يا هندسه لما بدخل الكود العربي بيبوط بيكون مكتوب زي كدا (ReMark = "ظٹطھط¨ظ‚ظ‰ ظ„ظƒظ… ") اي حلها
@QuantitiesSurveyingАй бұрын
وجزاكم بالمثل يا هندسة اقفل شيت الاكسل وافتحة تانى يا هندسة وجرب تانى وهيظبط معاك ان شاء الله ياما تكتبها انت بإيدك الكلام اللى بالعربى دة واذا مظبطش كلمنى على الواتس او الخاص فى الفيس بوك
@user-ku6ir8xi6sАй бұрын
ممكن ليسب أو الاضافه أو الرابط
@QuantitiesSurveyingАй бұрын
الإضافة دى والله يا هندسة بفلوس تقدر تكلمنى على الخاص فى الفيس او على الرقم دة واتس :+966560261116
@user-ku6ir8xi6sАй бұрын
يا باشمهندس انت شغال بإضافة ولا بليسب انت ازاي رابط بين الأوفيس والاتوكاد
@QuantitiesSurveyingАй бұрын
الإضافة معمولة عن طريق برمجة الفيجول بيسك فى الاتوكاد والاكسل يا هندسة ومربطين ببعض وداخل فيها استخدام لسبات
@asmaaorabi3041Ай бұрын
بالتوفيق دايما يا بشمهندس
@user-ku6ir8xi6sАй бұрын
مش شغال معايا البرنامج شيت اكسيل عادي
@QuantitiesSurveyingАй бұрын
شغال يا هندسة تقدر تكلمنى على الواتس +966560261116
@user-ku6ir8xi6sАй бұрын
عندك ايمو ياباشمهندس عشان الواتس مش شغال عندي
@QuantitiesSurveyingАй бұрын
@@user-ku6ir8xi6s لا والله يا هندسة معنديش ايمو للاسف تقدر تكلمنى على الفيس الرابط موجود فى وصف الفيديو
@QuantitiesSurveyingАй бұрын
' كود التفقيط بعملة الريال السعودى المستخدم فى الفيديو 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
@mohamedeid1993Ай бұрын
تسلم يا هندسه ❤
@Asmaa-up1stАй бұрын
بالتوفيق دائما وأبدا
@mohamedeid1993Ай бұрын
تسلم يا هندسه جزاك الله خير الجزاء ❤
@asmaaorabi30412 ай бұрын
بالتوفيق دايما يا بشمهندس
@QuantitiesSurveying2 ай бұрын
kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=lrPzOrO0WEiQ4LPK الاصدار النهائي لملف اكسل حصر الحديد مع رسم اشكال الحديد وكتابة الاطوال على اشكال الحديد
@QuantitiesSurveying2 ай бұрын
kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=lrPzOrO0WEiQ4LPK الاصدار النهائي لملف اكسل حصر الحديد مع رسم اشكال الحديد وكتابة الاطوال على اشكال الحديد
@MohSha-sj9eqАй бұрын
السلام عليكم ممكن ترسل الملف ياباش مهندس
@QuantitiesSurveying2 ай бұрын
kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=lrPzOrO0WEiQ4LPK الاصدار النهائي لملف اكسل حصر الحديد مع رسم اشكال الحديد وكتابة الاطوال على اشكال الحديد
@merak17022 ай бұрын
ربنا يباركلك يا هندسة من افضل للافضل ان شاءالله
@Skills-Hunters2 ай бұрын
ما شاء الله تبارك الله .. شغل عالي يا هندسه .. تسلم ايدك
@QuantitiesSurveying2 ай бұрын
😍😍
@ahmd_kmal19913 ай бұрын
للاسف مش شغال في في ادخال البيانات
@QuantitiesSurveying3 ай бұрын
شغال يا هندسة كلمنى على الرقم دة +966560261116
@mohamedeid19933 ай бұрын
جزاك الله خيرا يا هندسه ❤
@QuantitiesSurveying3 ай бұрын
وجزاكم بالمثل بالتوفيق يا هندسة
@QuantitiesSurveying2 ай бұрын
kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=YzlPOM7R_YJbRHdU الاصدار النهائي لحصر جميع اشكال الحديد
@Wok_Smart_Not_Work_Hard3 ай бұрын
بجد عااااااااش اوي يا هندسة و دائما موفق كدا و من نجاح ل نجاح دائما يارب 🔥🔥🙏💙 و بانتظار القادم اقوي باذن الله ❤️
@QuantitiesSurveying3 ай бұрын
الله يكرمك وشكرا على مرورك وتشجعيك تسلم يا هندسة 💖
@Wok_Smart_Not_Work_Hard3 ай бұрын
@@QuantitiesSurveying يا هندسة متقولش كدا احنا مبرمجين زي بعض و عندي مهندس برضو خلص كورس فيجوال بيسك بالاكسيل و بعت له الفديو بتاعك و ان شاء الله ممكن لو اتعاونتوا مع بعض تطلعوا شغل عالي اوي و اهو تلاقي حد يساعدك في الكود بدل م انت بتكتب كل دة لواحدك و انا ان شاء الله شهر كدا ولا حاجة و انزل بالتقيل بقي بس للريفيت 😅 ف انا حاسس بمعاناتك والله و فرحان جدا بالمنتج و الشكل النهائى اللي انت مطلعه بالاخراج دة و بالعظمة دي اكيد اخد منك شهور و يمكن سنة كمان عشان تطلع حاجة ب العظمة دي بجد تسلم ايدك 🔥❤️
@QuantitiesSurveying3 ай бұрын
@@Wok_Smart_Not_Work_Hard الحمدلله تعبنا وبنتعب وكلة بثوابة ان شاء الله وتشرفت بيك يا هندسة وليا الشرف نتعاون مع صديقك ومعاك ونتشارك افكارنا مع بعض وربنا يعينك ويوفقك فى الريفت ومنتظرين اعمالك
@QuantitiesSurveying2 ай бұрын
kzbin.info/www/bejne/eIvXgpmchJyEq5Isi=YzlPOM7R_YJbRHdU الاصدار النهائي لحصر جميع اشكال الحديد
@QuantitiesSurveying3 ай бұрын
facebook.com/groups/1344832723089730 يشرفنى انضمامك لجروب القناة
@eng.sameeral-lamoot20953 ай бұрын
نزلته بس مايشتغلش
@QuantitiesSurveying3 ай бұрын
الملف شغال يا هندسة تقدر تتواصل معايا على الرقم دة وانا ابعتلك الملف اكسل +966560261116
@mohamed.h.habashy4 ай бұрын
اصلي
@mohamed.h.habashy4 ай бұрын
انت جامد جدا
@mohamedmaisara91315 ай бұрын
بارك الله فيك ياباشمهندس، تواصلت امس معك فى الخاص ، وماقصرت .. حفظكم الله بحفظه
@QuantitiesSurveying5 ай бұрын
الله يكرمك يا بشمهندس بالتوفيق ان شاء الله
@yamenmahmoud19856 ай бұрын
سلام عليكم الشيت هايل بصراحة الله ينور ياهندسة ( بس عندي مشكلة معينة فى الشيت اني عايز اضيف شكل معين مش موجود فى الاشكال المتاحة ؟؟؟؟) ياريت ترد علية فى اقرب فرصة
@QuantitiesSurveying6 ай бұрын
اولا شكرا على تحفيزك يا هندسة بس الشيت معمول بالبرمجة وبيخد وقت ومجهود بس الفيديو دة شارح فية ملف اكسل لحصر الحديد بردة دة برمجة اسهل فلو حضرتك عايز تضيف شكل معين تواصل معايا رابط الفيس بوك الخاص بجروب القناة موجود فى الوصف فوق وان شاء الله اضيفة ليك فى الملف الاكسل المرفق فى رابط الفيديو دة مش هياخد منى وقت لان انا مشغول جدا والله وبحاول اسهل على المهندسين خصوصا مدنى kzbin.info/www/bejne/fZPVnahqjcqJn9E
@yamenmahmoud19856 ай бұрын
@@QuantitiesSurveying سلام عليكم ياهندسة انا حليت مشكلة اضافة اشكال معينة مافيش مشكلة بس في مشكلة في معادلة بتاعة نوعية الحديد لو انا بلف الكانات 10مم الرمز R بيفضل موجود مع ان المفروض الرمز يتغير الى y لحل المشكلة دى لازم تحط علامة = بعد علامة < عشان المعادلة تتظبيط
@goldengreenpalms09062 ай бұрын
@@yamenmahmoud1985 السلام عليكم ورحمه الله ازاي اشيل الزيادة في الطول اللي بتظهر في شكل الكانات
@mohamedarkaz26896 ай бұрын
ممتاز جزاك الله خيراً يا هندسة
@QuantitiesSurveying6 ай бұрын
وجزاكم بالمثل يا هندسة
@Wok_Smart_Not_Work_Hard7 ай бұрын
تسلم ايدك يا هندسة والله عااااااااش 👌🔥❤️
@QuantitiesSurveying7 ай бұрын
الله يكرمك يا هندسة تسلم 💙💙
@QuantitiesSurveying7 ай бұрын
facebook.com/groups/1344832723089730 يشرفنى انضمامك لجروب القناة
@maithamabdulzahra69787 ай бұрын
كيف اقدر احصل على هذه الاضافه
@QuantitiesSurveying7 ай бұрын
تقدر تتواصل معايا على الرقم دة يا هندسة واتس :966560261116+
@maithamabdulzahra69787 ай бұрын
كويس جدا
@maithamabdulzahra69787 ай бұрын
نزلته بس ما يعملش
@QuantitiesSurveying7 ай бұрын
الملف شغال يا هندسة ودة ملف اكسل بردة لحصر الحديد شغال بردة رابط الفيديو :kzbin.info/www/bejne/fZPVnahqjcqJn9Esi=3O57GtEAQwupc9Rf تقدر تتواصل معايا على الرقم دة واتس :966560261116+