abouelhassan

شكر وتقدير واحترام من اخيك

شكر وتقدير واحترام من اخيك

شفاه الله وعفاه وألبسه لباس الصحه والعافيه ان شاء الله

شكر وتقدير واحترام من اخيك

الف شكر اخى الكريم وكل عام وانتم بخير وصحة عندما اضفت الكود للبرنامج لدى توقف الكود هنا lRow = ActiveCell.SpecialCells(xlLastCell).Row

احتاج تعديل بلكود اخى يعمل من d2 وينفذ التعديل فى نفس العمود لا ينقل المعدل فf كل عام وانتم بخير وصحه وسلامه اشكرك اخي الكريم الحبيب

اخى فى الله أبوعيد اشكرك الكود لم يعمل اخى فى الله AbuuAhmed اشكرك ممتاز الكود ممتاز احتاج شرح بسيط

اخى فى الله حسونة حسين بارك الله فيك اخى الكود حول الارقام التى تحوى فاصلة الى 0 لم ينجح فى تحويلها الى رقم صحيح القرأة كرقم ده انا سجلت ماكرو بالاستبدال وبردو لم تنجح مش عارف السبب مشكووور

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

شكرا لك هذا غير مطلوب اخى

جرب لعله يكون مفيدا Private Sub Worksheet_Change(ByVal Target As Range) Dim ch As Variant Dim cell As Range ' تحقق إذا كانت التغييرات داخل النطاق المطلوب If Not Intersect(Target, Me.Range("E10:E1009")) Is Nothing Then Application.EnableEvents = False Application.ScreenUpdating = False ' ضبط الأسماء وإزالة المسافات الزائدة لكل خلية تم تغييرها For Each cell In Intersect(Target, Me.Range("E10:E1009")) ' ضبط الأسماء قبل عملية الأبجدة For Each ch In Array("إ", "أ", "آ") cell.Value = Replace(cell.Value, CStr(ch), "ا", 1, -1, vbTextCompare) Next cell.Value = Replace(cell.Value, "ة", "ه", 1, -1, vbTextCompare) cell.Value = Replace(cell.Value, "ي ", "ى ", 1, -1, vbTextCompare) ' إزالة المسافات الزائدة Do While InStr(cell.Value, " ") > 0 cell.Value = Replace(cell.Value, " ", " ") Loop cell.Value = Trim(cell.Value) Next cell Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

جرب لعله يكون مفيدا Private Sub Worksheet_Change(ByVal Target As Range) ' تحقق إذا كانت التغييرات داخل النطاق المطلوب If Not Intersect(Target, Me.Range("E10:E1009")) Is Nothing Then ' ضبط الأسماء قبل عملية الأبجدة Dim ch As Variant Application.ScreenUpdating = False With Me.Range("E10:E1009") For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا", , , True Next .Replace "ة", "ه", , , True .Replace "ي ", "ى ", , , True End With ' إزالة المسافات الزائدة Dim lr As Long, i As Long lr = Me.Cells(Me.Rows.Count, 5).End(xlUp).Row For i = 10 To lr Do While InStr(Me.Cells(i, 5), " ") > 0 Me.Cells(i, 5).Value = Replace(Me.Cells(i, 5), " ", " ") Loop Me.Cells(i, 5).Value = Trim(Me.Cells(i, 5).Value) Next i Application.ScreenUpdating = True End If End Sub

جرب لعله يفيدك Sub Names_Adjust() ' ضبط الأسماء قبل عملية الأبجدة ' -------------------------- Dim ch Application.ScreenUpdating = False With Range("E10:E1009") For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا", , , True Next .Replace "ة", "ه", , , True .Replace "ي ", "ى ", , , True End With ' إزالة المسافات الزائدة Dim sh As Worksheet, lr As Long, i As Long Set sh = ThisWorkbook.ActiveSheet lr = sh.Cells(Rows.Count, 5).End(xlUp).Row For i = 10 To lr Do While InStr(sh.Cells(i, 5), " ") > 0 sh.Cells(i, 5).Value = Replace(sh.Cells(i, 5), " ", " ") Loop sh.Cells(i, 5).Value = Trim(sh.Cells(i, 5).Value) Next i Application.ScreenUpdating = True End Sub

اشكرك اخى المرفق بالاعلى ولم يعمل

اولا اشكرك اخي الكود. يعطى خطأ والله اخى جربت اكواد كثيرة جدااااا ولم تعمل لذا كتبت الموضوع عسى يمدنا اخونا بكود يعمل بارك الله فى الجميع

السلام عليكم اخوانى لدى داتا كبيرة بها ارقام مثال 894.48 ٢٦١٥٫٣٥ الرقم الاول رفم اما الثانى فهو نص اقوم بنسخ الفواصل من الرقمين واستبدل الفاصلة الثانية بالاولى لتحويل الارقم ل ارقم بدل من نص حاولت تسجيل ماكرو وفشل مش عارف ليه احتاج لكود تحويل الكل على فرض ان الارقام تكمن فى العمود D من D2:D50000 مع خالص الشكر والتقدير الارقام والنصوص.xlsx

نحتاج من ابداعك اخى برنامج شامل لتصدير اى جدول إلى اكسيل مع تحديد مسار الحفظ واستيراد البيانات من الاكسيل إلى الجدول موضوع مهم للحفاظ ولنقل البيانات نحتاجه بلمسة احترافية من إبداعاتك مشكووور

شكر وتقدير واحترام من اخيك

ممكن تجرب الكود Sub CreateFolder() Dim ws As Worksheet Dim lastRow As Long Dim folderPath As String Dim folderName As String Dim fullPath As String Dim i As Long Set ws = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقة العمل الخاصة بك lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A (يمكن تغيير العمود إذا لزم الأمر) For i = 2 To lastRow ' يبدأ من الصف 2 ليتخطى العناوين folderPath = ws.Cells(i, 3).Value ' عمود C folderName = ws.Cells(i, 4).Value ' عمود D If folderPath <> "" And folderName <> "" Then fullPath = folderPath & "\" & folderName If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath MsgBox "Folder created: " & fullPath, vbInformation Else MsgBox "Folder already exists: " & fullPath, vbExclamation End If End If Next i End Sub

اخى فى الله استاذى حبيبي واخويا @ابوخليل اسعد الله قلبك مثل ما اسعدتنى ربنا يحفظك ويحفظ اسرتك الكريمة اللهم امين يارب العالمين

رفع الله قدرك اخى @ابوخليل وذادك من علمه وكرمه بصراحة لم اكن احلم اصل لهذه النتيجة ابدا بصراحة خيال روعة ما ينقصنى الاكتمال والكمال لله هو تصدير الثلاث تقرير اكسيل وpdf على الديسك توب وحاولت كتير اكواد كتير يعمل على جهاز ولا يعمل على اخر مش عارف السبب حفظكم الله وبارك الله فيك اخي الكريم

تسلم ايدك اخى الكريم حبيبى استاذ @ابوخليل كله جميل والله تحفة مش عارف اصدق الجمال والله روعة روعة بس فى شىء بسيط ظهر لى خطأ فى التاريخ فى عرضرالتقرير حاولت اصلحه بس فشلت ربنا يحفظك يارب ويديك الصحة والعافية

للرفع رفع الله قدرك اخى @ابوخليل

نحتاج هذا الموضوع

Up