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

أخي الكريم إليك حل آخر بدون استخدام أعمدة مساعدة .. إليك معادلة صفيف (أي بعد إدخال المعادلة يتم الضغط على Ctrl + Shift + Enter) =IFERROR(INDEX(Sheet1!$E$2:$E$7,MATCH(1,(Sheet1!$D$2:$D$7=$A2)*(Sheet1!$B$2:$B$7=B$1),0)),"") إذا لم تعمل المعادلة يمكنك استبدال الفاصلة العادية بفاصلة منقوطة ، وتوضع المعادلة في الخلية B2 ثم سحبها لأسفل وإلى اليسار إليك الملف المرفق مطبق فيه المعادلة VLOOKUP With Multiple Criteria Using INDEX And MATCH YasserKhalil.rar

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

أخي الكريم وائل كليك يمين على اسم ورقة العمل ثم الأمر View code ثم ضع الكود التالي Sub Transfer_Tables_Data() Dim CN, D As Integer, R As Integer, N As Integer Const C = 30, S = "*Area" Dim Rc As Range, Rg As Range CN = [{1,3,7,28,29,30}] D = 2 Application.ScreenUpdating = False If Me.UsedRange.Rows.Count > 1 Then Intersect(Me.UsedRange.Offset(1), Me.UsedRange).ClearContents Set Rg = Worksheets(1).UsedRange.Columns("B:C") Set Rc = Rg.Find(S, , xlValues, xlWhole) If Not Rc Is Nothing Then R = Rc.Row Do If Rc(0, 3).Value > "" Then With Rc.CurrentRegion.Columns(2).Rows N = .Find("*", , , , , xlPrevious).Row - Rc.Row - 2 Cells(D, 2).Resize(N + 1, 3).Value = Array(Rc(0, 12).Value, Rc(1, 3).Value, Rc(0, 3).Value) Cells(D, 5).Resize(N, 6).Value = Application.Index(Rc(4, 2).Resize(N, C).Value, Evaluate("ROW(1:" & N & ")"), CN) Cells(D + N, 5).Resize(, 6).Value = Application.Index(.Item(.Count).Resize(2, C).Value, 1, CN) D = D + N + 1 End With End If Set Rc = Rg.Find(S, Rc) Loop While Rc.Row > R Set Rc = Nothing End If Set Rg = Nothing Application.ScreenUpdating = True End Sub تقبل تحياتي

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

هل تم حل المشكلة أخي الكريم عمرو يبدو أنك لم تقيم الردود الأخيرة ..

الأخت رشا طبعاً هناك تضارب في المعلومات كما أرى .. في المشاركة الأولى ذكرتي أن الأعمدة المطلوب حذفها 5 أعمدة وفي المشاركة السابقة عمود واحد عموماً ..المهم الفكرة في الطلب .. بفرض أن المصنفات كلها مفتوحة في نفس الوقت ومعهم المصنف المرفق المسمى Test قومي بالنقر على زر الأمر RUN لتنفيذ الكود Sub DeleteColumnFromAllOpenWBs() Dim WB As Workbook For Each WB In Workbooks If WB.Name <> ThisWorkbook.Name Then WB.Worksheets("1").Columns(1).Delete End If Next WB MsgBox "Completed ...", 64 End Sub مرتبات شهر 12.rar

إليك معادلة الاخ الحبيب سليم مع تعديل رقم 5 إلى 4 لتظهر النتائج بشكل صحيح (وهي الأفضل في وجهة نظري حيث أنه لا داعي لأعمدة مساعدة) SALIM.rar

هل الرابط التالي نفس الموضوع يرجى وضع عنوان مناسب للموضوع أخي الكريم عمرو كما يرجى تغيير اسم الظهور للغة العربية

وهذا كود آخر أسرع من الأول Sub PrintPage() Dim MyRange As Range, Cel As Range, Rng As Range Application.ScreenUpdating = 0 Set MyRange = Range(Cells(8, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 1)) For Each Cel In MyRange If Cel.Value = 0 And Cel.Offset(, 4).Value = 0 Then If Not Cel Is Nothing Then If Rng Is Nothing Then Set Rng = Cel Else Set Rng = Union(Rng, Cel) End If Next Cel If Not Rng Is Nothing Then Rng.EntireRow.Hidden = True 'للطباعة [PrintOut] بكلمة [PrintPreview] استبدل كلمة ActiveSheet.PrintPreview Cells.EntireRow.Hidden = False Application.ScreenUpdating = 1 End Sub

أخي الكريم مختار جرب الكود التالي عله يفي بالغرض Sub PrintPage() Dim I As Integer Application.ScreenUpdating = 0 For I = 8 To Cells(Rows.Count, 1).End(3).Row If Cells(I, 1) = 0 And Cells(I, 5) = 0 Then Cells(I, 1).EntireRow.Hidden = True Next I 'للطباعة [PrintOut] بكلمة [PrintPreview] استبدل كلمة ActiveSheet.PrintPreview Cells.EntireRow.Hidden = False Application.ScreenUpdating = 1 End Sub

أختي الفاضلة ما هي الأعمدة التي تريدين حذفها .. هل ورقة العمل المقصود بها الورقة الأولى أي ورقة الضريبة أم ورقة العمل المسماة "1" ؟ حددي الأعمدة المراد حذفها عمود A وعمود B مثلاً (مثال لما يجب أن يتم طرحه)

الأروع دائماً مرورك العطر تواجدك بالمنتدى ..بلاش موضوع الغطسان ده ..خليك معانا على الدوام ..نفتقد وجودك ولمساتك السحرية تقبل وافر تقديري واحترامي

أخي الفاضل كريم هل تقصد هذا الملف؟ MSCAL.rar

أخي الكريم مهند الزيدي إليك الكود التالي عله يفي بالغرض Private Sub Workbook_Open() 'يوضع الكود في حدث المصنف ويقوم بإجبار المستخدم على تمكين الماكرو 'يعتمد الكود على ورقة عمل مخفية تقوم بوضع رسالة بها وتظهر في حالة 'عدم تمكين وحدات الماكرو وتختفي الورقة في حالة التمكين وتظهر أوراق المصنف 'وضع بها مربع نص عليه رسالة تنبيه للمستخدم [Prompt] قم بإنشاء ورقة باسم '------------------------------------------------------------------------ With Application .EnableCancelKey = xlDisabled .ScreenUpdating = False Call UnhideSheets .ScreenUpdating = True .EnableCancelKey = xlInterrupt End With End Sub Private Sub HideSheets() Dim Sheet As Object With Sheets("Prompt") If ThisWorkbook.Saved = True Then .[A100] = "Saved" .Visible = xlSheetVisible For Each Sheet In Sheets If Not Sheet.Name = "Prompt" Then Sheet.Visible = xlSheetVeryHidden End If Next If .[A100] = "Saved" Then .[A100].ClearContents ThisWorkbook.Save End If Set Sheet = Nothing End With End Sub Private Sub UnhideSheets() Dim Sheet As Object For Each Sheet In Sheets If Not Sheet.Name = "Prompt" Then Sheet.Visible = xlSheetVisible End If Next Sheets("Prompt").Visible = xlSheetVeryHidden Application.Goto Worksheets(1).[A1], True Set Sheet = Nothing ActiveWorkbook.Saved = True End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) With Application .EnableCancelKey = xlDisabled .ScreenUpdating = False Call HideSheets .ScreenUpdating = True .EnableCancelKey = xlInterrupt End With End Sub

أخي الكريم عمرو شعبان يرجى تغيير اسم الظهور للغة العربية يمكنك استخدام المعادلة التالية لتؤدي الغرض =LOOKUP(2,1/(Table1[الصنف]=K12),Table1[السعر]) إليك الملف المرفق فيه المعادلة Last Price YasserKhalil.rar

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

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

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

أخي الكريم هذا الموضوع لم أقم بحذفه ..إنما حذفت المكرر منه (أنا لا أقصد الإضرار بالأخوة الأعضاء) .إنما أقوم بعمل الإشراف

أخي الكريم أبو حمادة هل الموضوع على الرابط التالي نفس الموضوع ونفس الطلب أم أنهما مختلفين؟ يرجى الإفادة لعمل اللازم .. لو الموضوع مختلف حاول توضح أكتر في العنوان وفي تفاصيل الموضوع

أخي الكريم آه 54876 ..أهلا بك في المنتدى ومرحباً ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية

أخي الكريم مهند جرب الكود بعد التعديل Sub TarhilData2() Dim WS As Worksheet, SH As Worksheet Dim X As Long, Y As Long, Cell As Range Dim lRow As Long Set WS = Sheets("البيانات"): Set SH = Sheets("طبيب أطفال") Application.ScreenUpdating = False For Each Cell In WS.Range("X2:X11") If Not IsEmpty(Cell) Then X = Application.WorksheetFunction.Match(Cell.Value, SH.Rows(1), 0) lRow = SH.Cells(49, X).End(xlUp).Row + 1 WS.Range(Cell.Offset(, -22), Cell.Offset(, -20)).Copy SH.Cells(lRow, X).PasteSpecial xlPasteValues Cell.Offset(, -1).Copy SH.Cells(lRow, X + 3).PasteSpecial xlPasteValues Cell.Offset(, 3).Copy SH.Cells(lRow, X + 4).PasteSpecial xlPasteValues End If Next Cell Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

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

بارك الله فيك أخي الحبيب سليم الحل المرفق من قبلك ليس بكود إنما بمعادلات ..وجب التنويه

جرب تغير الفاصلة الموجودة في المعادلة إلى فاصلة منقوطة