alliiia

طيب اعملها عن طريق mailing خاصية في الوورد ابحث عنها في اليوتيوب

وعليكم السلام ورحمة الله وبركاته تفضل مطلوبك وبالتوفيق تعديل فورم.7z

الله ينفع بك أستاذنا محمد هشام تم تعريف المتغيرات حتى لا تحصل مشاكل مستقبلية تم إضافة جزئية الحصول على مسار سطح المكتب للمستخدم الحالي بحيث ما تتعب مستقبلا في نقل الملف لكمبيوتر آخر Sub SaveBackup() Dim filePath As String Dim FolderName As String Dim copyName As String Dim ThisBook As Workbook Set ThisBook = ThisWorkbook ' هنا سيتم الحصول على مسار الجهاز filePath = Environ("UserProfile") & "\Desktop" FolderName = "BACKUPS" With Application .ScreenUpdating = False .DisplayAlerts = False copyName = filePath & "\" & FolderName & " " & Format(Now, "dd-mmmm-yyyy") If Dir(copyName, vbDirectory) = "" Then MkDir copyName ThisBook.SaveCopyAs copyName & "\" & ThisBook.Name & " " & _ Format(Now, "dd-mmmm-yyyy-HH-MM-SS") & ".xlsm" Application.OnTime Now + TimeValue("00:10:00"), "SaveBackup" .DisplayAlerts = True .ScreenUpdating = True End With End Sub

الحمد لله رب العالمين

العفو المعذرة لم أنتبه جيدًا لكلامك وتفضل إليك التعديل selse.xlsm

وعليكم السلام ورحمة الله وبركاته بالتوفيق أخي selse.xlsm

مرحبا أخي نعم راح يفرغ الجدول لأن الكود يحتوي على تفريغ: Mj.Range("K5:K14").ClearContents لذلك قمت بعمل ملف آخر جديد وكتابة كود آخر جديد يقوم بما تريده بإذن الله بشكل جميل أي ملاحظة أنا حاضر. ادخال البيانات.xlsm هذه أكواد تفريغ شاشة الإدخال: sourceSheet.Range("H4").ClearContents sourceSheet.Range("H6").ClearContents sourceSheet.Range("H7").ClearContents sourceSheet.Range("H8").ClearContents sourceSheet.Range("H9").ClearContents sourceSheet.Range("H10").ClearContents sourceSheet.Range("H11").ClearContents sourceSheet.Range("H13").ClearContents احذف الذي لا تريده وابقي على الذي تريده

وعليكم السلام ورحمة الله وبركاته تفضل قبل فتح الملف اضغط بزر الفأرة يمين ثم اذهب للخصائص وحط صح على علامة التحذير واضغط موافق ولا تنس تفعيل الماكرو في اعدادات الاكسل حتى يعمل معك الزر وهذا هو الكود المستخدم في الملف: Sub MergeAndCenter() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row Dim startRow As Long, endRow As Long startRow = 1 Dim i As Long Application.DisplayAlerts = False For i = 1 To lastRow If i = lastRow Or ws.Cells(i, 3).Value <> ws.Cells(i + 1, 3).Value Then endRow = i If endRow > startRow Then ws.Range(ws.Cells(startRow, 3), ws.Cells(endRow, 3)).Merge ws.Range(ws.Cells(startRow, 3), ws.Cells(endRow, 3)).HorizontalAlignment = xlCenter End If startRow = i + 1 End If Next i Application.DisplayAlerts = True End Sub اختبار1.xlsm

وعليكم السلام ورحمة الله وبركاته لماذا لم تكمل جميلك وترفع الملف؟؟ وتشرح مشكلتك؟ على العموم جرب هذه: Sub insert02() Dim Mj As Worksheet Dim Mn As String Dim Mt As Worksheet Dim last As Integer Set Mj = ThisWorkbook.Sheets("Main") Mn = Mj.Range("L2").Value On Error Resume Next Set Mt = ThisWorkbook.Sheets(Mn) On Error GoTo 0 If Mt Is Nothing Then MsgBox "ورقة العمل '" & Mn & "' غير موجودة. تحقق من الاسم في الخلية L2.", vbExclamation Exit Sub End If last = Mt.Range("B10000").End(xlUp).Row + 1 With Mt .Cells(last, "B").Value = Mj.Range("K5").Value .Cells(last, "C").Value = Mj.Range("K6").Value .Cells(last, "D").Value = Mj.Range("K7").Value .Cells(last, "E").Value = Mj.Range("K8").Value .Cells(last, "F").Value = Mj.Range("K9").Value .Cells(last, "G").Value = Mj.Range("K10").Value .Cells(last, "H").Value = Mj.Range("K11").Value .Cells(last, "I").Value = Mj.Range("K12").Value .Cells(last, "J").Value = Mj.Range("K13").Value .Cells(last, "K").Value = Mj.Range("K14").Value End With Mj.Range("K5:K14").ClearContents End Sub

حاول تجعل تنسيق الخلية بنوع نص (TEXT) ويوجد طريقة أن تجعل داخل الأرقام علامة تنصيص مثل هذه العلامة ( ' ) جرب وبيضبط معك إن شاء الله.

Sub Test () Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") 'غير لاسم الشيت حقك Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row Dim i As Long For i = 2 To lastRow ' If ws.Cells(i, "B").Value <= 9 Then ws.Cells(i, "N").Value = ws.Cells(i, "E").Value & "0" & ws.Cells(i, "C").Value & "000000" & ws.Cells(i, "B").Value ElseIf ws.Cells(i, "B").Value <= 99 Then ws.Cells(i, "N").Value = ws.Cells(i, "E").Value & "0" & ws.Cells(i, "C").Value & "00000" & ws.Cells(i, "B").Value End If Next i End Sub

وفيك بارك الله آمين وإياك تفضل تم التعديل وفق ما طلبت بالتوفيق بحث عن الأصناف.xlsm

لا يوجد في الاكسل لكن جرب Google Speech-to-Text ربما يفيدك شوي بس تحتاج تراجع خلفه شيء أكيد

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

تفضل إذا في ملاحظات أخبرني need help.xlsx