سليم حاصبيا

الماكرو ما زال يعمل كما تريد + توزيع الاشطر (الصفحة الاولى )

تم توزيع الاشطر (بواسطة المعادلات) على فكرة اذا كنت تريد توزيع الاشطر اولاً فأنت لست بحاجة للماكرو كما في الورقة salim من هذا الملف Fatura_new.xlsm

شاهد هذا الفيديو https://www.youtube.com/watch?v=3rvSsA6S47k

اضغط باستمرار على مفتاح Shift اثناء عملية فتح الملف

جرب هذا الملف الكود Option Explicit Function how_to_pay(Myfact#, n1#, n2#, n3#) As Double '''''''''''''''''''''''''''''''''''''''''' Dim How_Many# Select Case Myfact Case Is <= 100 How_Many = Myfact * n1 ' a Case Is <= 200 How_Many = (100 * n1) + (Myfact - 100) * n2 ' a+b Case Is > 200 How_Many = (100 * n1) + (100 * n2) + (Myfact - 200) * n3 'a+c+d End Select how_to_pay = How_Many '''''''''''''''''''''''''''''''''''''''' End Function Fatura.xlsm

تم التعديل على الماكرو كما تريد My_book (1).xlsm

جرب هذا الكود النتيجة في شيت SALIM Option Explicit Sub FILL_DATA() Dim R#, i#, m#: m = 2 Dim Maj As Worksheet, Sal As Worksheet Set Maj = Sheets("مجاني") Set Sal = Sheets("SALIM") Sal.Range("A2", Range("A1").End(4)).ClearContents R = Maj.Cells(Rows.Count, "Z").End(3).Row For i = 2 To R If Maj.Cells(i, "Z") <> vbNullString Then Sal.Cells(m, 1) = Maj.Cells(i, "Z") m = m + 1 End If Next End Sub الملف مرفق My_book.xlsm

استبدل الى هذه المعادلة =CHOOSE(($U2<$Y2)+($Y2="")+1,"",F2)

لاثراء الموضوع هذه المعادلة في الخلية C7 Ctrl+Shift+Enter =IFERROR(INDEX(Sheet1!$D$2:$D$100,SMALL(IF(Sheet1!$D$2:$D$100<>"",IF($A7&"*"&C$5=Sheet1!$B$2:$B$100&"*"&Sheet1!$A$2:$A$100,ROW($A$2:$A$100)-ROW($A$2)+1)),COUNTIF($A$7:$A7,$A7))),"")

أهو بالمصري تعني زي ما أنت شايف

ما احنا استعملناها أهو

لك ما تريد My_data.xlsm

أمرك غريب يا صديقي ترسل ملف فارغ تماماً و تريد ان تبحث عن كلمة وهمية لا نعرف ما هي و اذا لم نجدها تبحث عن كلمة اخرى بردو وهمية هو ايه الكلام دا

ربما الهاتف عندك لا يدعم المعادلات في اكسل (لاني ارى ان الصورة المرفقة مأخوذة من هاتف )

وضعت لك جدولاً لتتأكد من المواد المستخدمة والمواد الباقية tones_check.xlsx

كيف نلزم المستخدم بالكتابة 1-بأحرف صغيرة فقط 2-أو احرف كبيرة فقط 3-او اختيار (كبيرة أو صغيرة) حصراً للمزيد هذا الملف Upper_Lower.xlsx

جرب بنفسك ان تغير في الرصيد مثلاً استبدل في الرصيد 7000 بـــ 10000 أو 600 بــــ 250 و ترى النتيجة

بدون ملف مرفق من الصعب التكهن لكن ربما يفيدك هذا المثال tones.xlsx

دون الملف لا تلقى مساعدة

لا لزوم للكود في هذه الحالة تكفي هذه المعادلة ( في الخلية C2 و تسحب نزولاً) =SUMPRODUCT((الديون!$C$6:$C$100=$B2)*(الديون!$E$6:$E$100-الديون!$G$6:$G$100))

بعد اذن الاخ حسين 1-هذا الكود يضيف لك Hypperlink من كل صفحة (في الخلية F1) الى الصفحة الرئيسية SALIM 2-في حال تكرار الاسم الماكرو يتجاهل هذا الامر (دون رسالة خطأ) 3-كما يضيف لك حرية الانتقال الى الصفحة التي تريد من خلال الضغط على الاسم الذي تحتة خط في الصفحة SALIM 4-كل ما عليك هو تغيير اسم الشيت الاولى الى SALIM لحسن نسخ الكود ولصقة دون ظهور احرف و كلمات غير مفهومة في الكود Option Explicit Sub ADD_SH_with_Hyper() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 5/11/2019 Dim Rg As Range Dim sh As Worksheet Dim LA%, K%, i%, m%: m = 2 Dim x Dim ws As Worksheet Set sh = Sheets("SALIM") Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> "SALIM" Then ws.Delete End If Next Application.DisplayAlerts = True LA = sh.Cells(Rows.Count, 1).End(3).Row For Each Rg In sh.Range("A2:A" & LA) If Rg.Value <> "" Then If Not Application.Evaluate("ISREF('" & Rg.Value & "'!A1)") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = Rg.Value With ActiveSheet .Hyperlinks.Add Anchor:=.Range("F1"), Address:="", SubAddress:= _ "SALIM!A1", TextToDisplay:="Goto SALIM" For K = 2 To LA If sh.Range("A" & K) = .Name Then .Cells(m, 2) = sh.Range("B" & K) m = m + 1 End If Next K m = 2 .Cells(1, 2) = .Name .Range("B:B,F:F").EntireColumn.AutoFit End With End If End If Next Rg With Sheets("SALIM") .Hyperlinks.Delete For i = 2 To LA x = Application.CountIf(sh.Range("A2:A" & i), sh.Range("A" & i)) If x = 1 Then .Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:= _ "'" & .Range("A" & i) & "'!A1", TextToDisplay:=.Range("A" & i).Value Else sh.Range("A" & i).Font.Underline = False End If Next .Select Application.ScreenUpdating = True End With End Sub الملف مرفق للتجربة Create_sheet_with Hyperlink.xlsm

لك ما تريد maktaba_2.xls

هل يمكن ان يتكرر نفس الصف لا وجود للمستحيل مع اكسل فقط جرب هذا الملف maktaba.xls

العامود C يحتوي على خلايا فارغة التي توقف الكود عن عمله مثلاً الخلية C143

الملف يعمل عل أكمل وجه مرفق مع الكود mosharikin.xlsm