ياسر خليل أبو البراء

ضع الحل هنا ليستفيد الجميع ..تقبل تحياتي

أخي الكريم إذا أردت مسح نطاق محدد في أوراق العمل المعنية ما عليك سوى إضافة سطر واحد فقط ، وهو موضح بالفيديو بشكل تفصيلي بعد السطر التالي sh.PrintPreview 'Change PrintPreview To PrintOut أضف السطر التالي بهذا الشكل sh.Range("A1:B3").ClearContents غير النطاق المكتوب للنطاق المطلوب

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

ارفق ملفك للإطلاع عليه .. ومحاولة العمل عليه إن شاء الله

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

وعليكم السلام انسخ الدالة المعرفة التالية (للأخ الحبيب مختار حسين) وضعها في موديول عادي Standard Module (من خلال Insert ثم اختر الأمر Module) Function MokhtarCountif(MyVal As String, AddressRange As Range) As Long Dim C As Range, Total As Long, Arr() As String, J As Integer Application.Volatile True For Each C In AddressRange.Cells Arr = Split(C, " ") For J = LBound(Arr) To UBound(Arr) If Arr(J) = MyVal Then On Error Resume Next Total = Total + 1 On Error GoTo 0 End If Next J Next C MokhtarCountif = Total End Function ثم استخدم المعادلة التالية في ورقة العمل بهذا الشكل =MokhtarCountif("الله",C2:C5)

جرب في الخلية المجاورة للخلية D2 المعادلة التالية =VALUE(SUBSTITUTE(SUBSTITUTE(D2,"٬",""),"٫",""))

غير السطر التالي If Application.WorksheetFunction.CountBlank(sh.Cells) <> sh.Cells.CountLarge Then ليصبح بهذا الشكل بفرض أن النطاق هو A1:B3 If Application.WorksheetFunction.CountBlank(sh.range("A1:B3")) <> sh.range("A1:B3").Count Then

يمكن وضع أوراق العمل الثمانية في مصفوفة والعمل عليها فقط Sub Test() Dim sh As Worksheet Application.ScreenUpdating = False For Each sh In Sheets(Array("Sheet1", "Sheet2")) 'Put Your Sheet Names Here If Application.WorksheetFunction.CountBlank(sh.Cells) <> sh.Cells.CountLarge Then sh.PrintPreview 'Change PrintPreview To PrintOut End If Next sh Application.ScreenUpdating = True End Sub

أي لاونجي ..الكود واضح أهو .. لو فيه حاجة مش واضحة استفسر عنها ، بس حاجة واحدة مش كل الكود

وجزيت خيراً بمثل ما دعوت لي أخي الكريم الحمد لله الذي بنعمته تتم الصالحات

وعليكم السلام جرب الكود التالي Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim str As String Dim x As Long Dim i As Long Dim j As Long Set ws = Sheets("BUY") Set sh = Sheets("STORE") arr = ws.Range("E2:FJ" & ws.Cells(Rows.Count, 5).End(xlUp).Row).Value Application.ScreenUpdating = False For x = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row str = sh.Cells(x, 1).Value For i = UBound(arr, 1) To LBound(arr, 1) Step -1 For j = UBound(arr, 2) - 5 To LBound(arr, 2) Step -6 If arr(i, j) <> "" And arr(i, j) = str Then sh.Cells(x, 6).Value = arr(i, j + 1) sh.Cells(x, 7).Value = arr(i, j + 2) sh.Cells(x, 8).Value = arr(i, j + 3) sh.Cells(x, 10).Value = arr(i, j + 4) sh.Cells(x, 9).Value = arr(i, j + 5) GoTo Skipper End If Next j Next i Skipper: Next x Application.ScreenUpdating = True End Sub

وعليكم السلام جرب الكود التالي Sub Test() Dim sh As Worksheet Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> "الرئيسية" And Application.WorksheetFunction.CountBlank(sh.Cells) <> sh.Cells.CountLarge Then sh.PrintPreview 'Change PrintPreview To PrintOut End If Next sh Application.ScreenUpdating = True End Sub

تمام الأسطر المشار إليها عدل فيها براحتك بحيث يناسب ملفك وهذا هو المقصد من الكود أن يكون مرن ويمكن تعديله بسهولة تقبل تحياتي

دور على السطر في الكود اللي فيه جملة DisplayRightToLeft وشيل السطر دا وهيظبط معاك زي ما إنت عايز

جرب تحذف الجزء الأخير من السطر من أول الفاصلة ورقم 16

إن شاء الله يفضل شغال وجرب بنفسك وشوف ولو قابلتك مشكلة أعطنا صورة للمشكلة لنتمكن من تقديم المساعدة المطلوبة

بسم الله ما شاء الله أخي العزيز محمد أبو صهيب موضوعاتك في قمة الجمال والروعة .. بارك الله فيك وجزاك الله كل خير

جربت الملف ويعمل بشكل جيد .. تأكد من أن الملف قد تم استخراجه من الملف المضغوط بشكل صحيح ثم حاول مرة أخرى .. اضغط Alt + F8 بعد فتح الملف ، واختر الماكرو الموجود ثم انقر Run

هل قمت بوضع الأسماء القديمة في العمود الأول والأسماء الجديدة في العمود الثاني؟

قم بالإطلاع على الملف في الرابط التالي لعله يفيدك إن شاء الله الرابط من هنا

بارك الله فيك أخي الكريم الزباري اسمح لي بمشاركة بسيطة بالموضوع .. طالما أن كود الاستدعاء يمكن أن يستخدم أكثر من مرة فالأفضل وضعه في إجراء يمكن الاستدعاء منه ..اطلع على الكود وستعرف مقصدي Sub ImportAhmad() ReadString "ahmad", Sheet2 End Sub Sub ImportAli() ReadString "ali", Sheet3 End Sub Sub ImportYosuf() ReadString "yosuf", Sheet4 End Sub Sub ReadString(customer As String, sh As Worksheet) Dim sLine As String Dim sFName As String Dim intFNumber As Integer Dim lRow As Long Dim lColumn As Long Dim vDataValues As Variant Dim intCount As Integer sFName = ThisWorkbook.Path & "\Info\" & customer & ".txt" intFNumber = FreeFile On Error Resume Next Open sFName For Input As #intFNumber If Err.Number <> 0 Then MsgBox "Text File Not Found!", vbCritical, "Error!" Exit Sub End If On Error GoTo 0 sh.Cells.Clear lRow = 1 Do While Not EOF(intFNumber) Line Input #intFNumber, sLine vDataValues = Split(sLine, vbTab) With sh lColumn = 1 For intCount = LBound(vDataValues) To UBound(vDataValues) .Cells(lRow, lColumn) = vDataValues(intCount) lColumn = lColumn + 1 Next intCount .Cells.EntireColumn.AutoFit .Activate .Range("A1").Select End With lRow = lRow + 1 Loop Close #intFNumber MsgBox "Values From File '" & sFName & "' Were Imported To Sheet '" & sh.Name & "'!", vbInformation End Sub

وعليكم السلام Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim myDate As Date myDate = CDate(ComboBox1.Value) TextBox1.Value = Format(Day(myDate), "ddd") TextBox2.Value = MonthName(Month(myDate)) TextBox3.Value = Year(myDate) End Sub

بارك الله فيكم إخواني الكرام وجزاكم الله خيراً شرفني مروركم العطر بالموضوع ..أخي الكريم فضل : أفضل الغناء والعزف بالأكواد ، فهذه لعبة أعشقها أكثر تقبلوا تحياتي

بارك الله فيك أخي العزيز الزباري على هذا الموضوع المتميز .. تقبل وافر تقديري واحترامي