طارق محمود

السلام عليكم ماشاء الله جهد كبير من باحث متميز جزاك الله خيرا ونفع بك

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

السلام عليكم أخي العزيز أضفت العمود G للمادة المسيحية ووضعت لك الكود التالي في حدث الورقة Private Sub Worksheet_SelectionChange(ByVal Target As Range) r = Target.Row [E:G].EntireColumn.Hidden = False If Cells(r, "G") = "n" Or Cells(r, "G") = "N" Then [G:G].EntireColumn.Hidden = True: Exit Sub If Cells(r, "E") = "n" Or Cells(r, "E") = "N" Or _ Cells(r, "F") = "n" Or Cells(r, "F") = "N" Then [E:F].EntireColumn.Hidden = True End Sub وكل ماعليك أن تكتب الحرف n أو N أمام كل طالب في غير ديانته وسيخفي الكود أوتوماتيك عمود الديانة الذي به الحرف n أو N عندما تقف بالماوس علي أي خلية بصف الطالب جرب المرفق وحدة دنقلا2.rar

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

السلام عليكم ردا علي أخي فضل أضف السطر التالي في أول الكود [E5].ClearContents أضف أبوستروف قبل السطر الأخير من الكود لإلغاؤه ليصبح '[G10:G100].FillDown أو إلغيه وفي النهاية يكون الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$4" Then Exit Sub [E5].ClearContents LR = [A10000].End(xlUp).Row [B1].Copy ([G11]) Range("A1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[F3:F4], CopyToRange:=[G11], Unique:=True con = WorksheetFunction.CountA([G11:G20]) Select Case con Case 1: Exit Sub Case 2: x = [G12]: GoTo 10 Case Else x = [G12] For i = 13 To [G10000].End(xlUp).Row x = x & " - " & Cells(i, "G") Next End Select 10 [E5] = x End Sub

السلام عليكم أخواني الأحباب جزاكم الله خيرا الجزاء أشكركم جميعا علي كلماتكم الطيبة ومروركم الكريم أخي السائل تفضل حل بالمعادلات ولكن يعيبه اننا نحتاج لللمساحة الملونة بالأصفر ، لاتدخلها في ملفك ولافي طباعتك فهي مهمة لإتمام المعادلات يمكنك إخفاؤها تفضل الملف تجميع اسماء الاطعمة المذكورة امام المطعم فى خلية واحدة_معادلات.rar

أخي العزيز الملف لايعمل معي كما قلت لك سابقا ويعطي رسالة خطأ لأن الأوفيس لدي غير كامل لكن جرب التالي في أول الكود لكلا من الفورم1 والفورم2 إستبدل Option Explicit '****************************************************** Private Const Mysh_Name As String = "sheet6" بالتالي Option Explicit '****************************************************** Private Const Mysh_Name As String = ActiveWorkbook.Path & "\DataBase.xlsx\Sheet1"

السلام عليكم أخي العزيز ضع الكود التالي في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$4" Then Exit Sub LR = [A10000].End(xlUp).Row [B1].Copy ([G11]) Range("A1:B" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[F3:F4], CopyToRange:=[G11], Unique:=True con = WorksheetFunction.CountA([G11:G20]) Select Case con Case 1: Exit Sub Case 2: x = [G12]: GoTo 10 Case Else x = [G12] For i = 13 To [G10000].End(xlUp).Row x = x & " - " & Cells(i, "G") Next End Select 10 [E5] = x [G10:G100].FillDown End Sub أو تفضل المرفق وبه المطلوب تجميع اسماء الاطعمة المذكورة امام المطعم فى خلية واحدة.rar

السلام عليكم الموضوع طويل وليس سهلا كما توقعت عموما هذه محاولة غير كاملة ستسهل علي من يريد المحاولة تفضل والمحاولة في الورقة TAREQ سميت بعض المجالات للتسهيل وهذا هو الكود Sub distrb() Dim w(5), A(5, 5), B(5, 5), RA(5), RB(5) As Variant, ch, wa, ASAS As Range Set ch = Range("Choose") Set ASAS = Range("ASASAT") Set wa = Range("Waseet") Set RS = Range("Result") RS.ClearContents [A9.AR100].Interior.ColorIndex = xlNone If WorksheetFunction.CountA(ch) < 3 Then MsgBox ("Please Choose the 3 elements then press again !!"): Exit Sub For Each t In ASAS If ch(1) = t Then adr1 = t.Address If ch(2) = t Then adr2 = t.Address Next t adr1 = Range(adr1).Offset(-6, -3).Address adr2 = Range(adr2).Offset(-6, -3).Address For i = 1 To 5 ' عناصر الأساس الأول والثاني For j = 1 To 5 A(i, j) = Range(adr1).Offset(i, j) Range(adr1).Offset(i, j).Interior.ColorIndex = 6 B(i, j) = Range(adr2).Offset(i, j) Range(adr2).Offset(i, j).Interior.ColorIndex = 4 Next j Next i For Each t In wa If ch(3) = t Then adr = t.Address Next t For i = 1 To 5 'عناصر الوسيط w(i) = Range(adr).Offset(i, 0) RS(i, i) = w(i) Next i For i = 1 To 5 ' each elment of Waseet For j = 1 To 5 ' Get the right column in both arraies For k = 1 To 5 If w(i) = A(j, k) Then col_1 = k If w(i) = B(j, k) Then col_2 = k Next k Next j For j = 1 To 5 RA(j) = A(j, col_1) RB(j) = B(j, col_2) ' [bf19].Offset(j, 0) = A(j, col_1) ' [bg19].Offset(j, 0) = B(j, col_2) Next j ' [AZ19].Offset(i, 0) = col_1 ' [AZ25].Offset(i, 0) = col_2 For j = i + 1 To 5 'rows If RS(i, j) > 0 Then GoTo 10 For k = 1 To j - 1 If RA(j) = RS(i, k) Then exchg = RA(j) RA(j) = RA(k) RA(k) = exchg End If Next k RS(i, j) = RA(j) 10 Next j For j = i + 1 To 5 'columns If RS(j, i) > 0 Then GoTo 20 For k = 1 To j - 1 If RB(j) = RS(k, i) Then exchg = RB(j) RB(j) = RB(k) RB(k) = exchg End If Next k RS(j, i) = RB(j) 20 Next j Next i End Sub وهذا هو المرفق تفضل المربعات2.rar

السلام عليكم أخي العزيز السؤال غير واضح تماما إشرح لي يدويا كيف تصل للنتيجة العلوية من المربعات D6 + C2 + Z ثم إن شاء اله تجد من يساعد

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

السلام عليكم مرفق ملف به دالة تم تصنيعها لهذا الغرض الدالة هي search_T علي غرار دالة search الجاهزة بالإكسل وكودها Function search_T(s As Variant, r As Range) x = Len(s) For Each ce In r For j = 1 To Len(ce) - x + 1 If Mid(ce.Value, j, x) <> Format(s) Then GoTo 10 search_T = "صف " & ce.Row GoTo 20 10 Next j Next ce search_T = "غير موجود" 20 End Function تفضل المرفق search_TAREQ.rar

السلام عليكم عفوا أخي أحمد لم اقرأ أو أري تكرار الموضوع لقلة الوقت ، سماح

السلام عليكم أخي العزيز أنظر المرفق وبه الشرح 12.rar

السلام عليكم أخي العزيز بعد إذنك أزلت صورة الترحيب الأولي فهي التي تزيد جدا من حجم الملف مرفق الملف وبه التعديلات لم استطع التأكد من النتيجة فالملف يعطي رسالة خطأ لأن الأوفيس لدي غير كامل جرب وأعلمني بالنتيجة تفضل المرفق Khalidia.rar

السلام عليكم أخي العزيز أولا لابد من ارسال الملف الآخر al khalidiya ثانيا ضع الكود التالي في حدث فتح الملف Workbook Private Sub Workbook_Open() Sheets(1).[A46] = Sheets(1).[A46] + 1 End Sub

السلام عليكم أخي العزيز أنظر المرفق قف علي أي من الخلايا الصفراء واختر اسم المورد تجد بيانات في اللأعمدة المجاورة قائمه منسدله للموردين.rar

السلام عليكم أخي العزيز أهلا ومرحبا بك بين إخوانك حاولت المساعدة لأنها أول مشاركة لك ولم أستطع ضع ماتريد في صورة جدول بالإكسل ثم إضغط الملف باستخدام WINRAR أو WINZIP أنظر المرفق لتقريب سؤالك حساب العموله.rar

السلام عليكم أخي العزيز ضع المعادلة التالية في الخلية D3 =IFERROR(SEARCH(117,C3),"غير موجود") ثم انسخها للأسفل بعد إذنك سأحذف الموضوع المتشابه

السلام عليكم للخطوات الصحيحة، أنظر اخي الفيديو المرفقChart.rar

السلام عليكم تفضل أخي ranie هذا الكود Sub Shift_DATA() Application.DisplayAlerts = False pt = ActiveWorkbook.Path On Error Resume Next LR = [A60000].End(xlUp).Row If LR < 2 Then Exit Sub Range("A2:C" & LR).Copy Workbooks.Open Filename:=pt & "\2.xlsx" Workbooks("2.xlsx").Activate NR = Sheets(1).[A60000].End(xlUp).Row + 1 Sheets(1).Cells(NR, "A").Select ActiveSheet.Paste Application.CutCopyMode = False [A60000].End(xlUp).Select ActiveWorkbook.Save ActiveWindow.Close Workbooks("1.xlsm").Activate Range("A2:C" & LR).ClearContents Application.DisplayAlerts = True End Sub وهذا المرفق ranie.rar

السلام عليكم تفضل اخي الملف المرفق وبه الكود المطلوب وهاهو الكود لو أردت وضعه في الملف عندك Sub Macro1() ' ' Macro1 Macro ' Dim sms As String pth = ActiveWorkbook.Path For i = 1 To Sheets.Count Sheets(i).Select Sheets(i).Copy sms = sms & Chr(10) & [B4] ActiveWorkbook.SaveAs Filename:=pth & "\" & [B4] & ".xls", FileFormat:=xlExcel8 ActiveWindow.Close Next i Sheets(1).Select MsgBox ("تم حفظ الملفات التالية:" & sms) End Sub copyFiles.rar

السلام عليكم بعد إذن أخي العزيز / جمال الفار ردا علي أخونا السائل يوجد شرح سابق لي في هذه النقطة حمل الملف الذي إسمه 2Machines_explain.xls في المشاركة رقم 18 في الموضوع التالي http://www.officena.net/ib/index.php?showtopic=34508&st=0 إن شاء الله ستفهم هذه النقطة جيدا الموضوع نفسه هندسي فلايهمك الموضوع ولكن يهمك الورقة "الشرح" بالملف

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

كان عندي خطأ في الجهاز لذلك كانت علامات <> كثيرة عدلت المشاركة السابقة