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

أخي الكريم كاسر الأمواج استبدل الأسطر التي يظهر بها الخطأ باللون الأحمر بهذه الأسطر #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function GetActiveWindow Lib "user32.dll" () As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function BringWindowToTop Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "User32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long #End If ستجد الأسطر في أكثر من فورم ..لا تنزعج وأنت تعدل ..قم بحذف الأسطر باللون الأحمر وضع الكود عاليه مكانها وإن شاء الله يعمل معك تقبل تحياتي

بارك الله فيك أخي الكريم وجزاكم الله خيراً هلا غيرت اسم الظهور للغة العربية تقبل وافر تقديري واحترامي

أخي الكريم حمادة جرب التعديل في الجزء الخاص ببدء تشغيل الفورم Private Sub UserForm_Initialize() Dim C As Integer For C = 1 To ContColmn With ورقة1 Me.Controls("xx" & C).Caption = .Cells(1, C).Value End With Next With ورقة1 Me.ComboBox2.AddItem .Cells(1, 1).Value Me.ComboBox2.AddItem .Cells(1, 2).Value Me.ComboBox2.AddItem .Cells(1, 33).Value End With Me.ComboBox2.Style = 2 End Sub تقبل تحياتي

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

بارك الله فيك أخي العزيز محمد الطيب وجزاكم الله خيراً على هداياك الثمينة تقبل وافر تقديري واحترامي

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

الحمد لله الذي بنعمته تتم الصالحات بوركت أخي العزيز سامح طاهر .. تقبل تحياتي

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

وجزيت خيراً بمثل ما دعوت وزيادة أخي وحبيبي أبو بسملة التنوع في الحلول يثري الموضوعات بشكل كبير تقبل تحياتي

في الخلية Q2 ضع المعادلة التالية (معادلة صفيف) =IFERROR(INDEX($C$2:$C$13,SMALL(IF(FREQUENCY(MATCH($C$2:$C$13,$C$2:$C$13,0),MATCH($C$2:$C$13,$C$2:$C$13,0))>0,ROW($C$2:$C$13)-1),ROW(A1))),"") تقبل تحياتي

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

قم باستبدال الفاصلة العادية بفاصلة منقوطة والشرط ضعه بين أقواس تنصيص أخرى غير الموجودة .Range("g6").Formula = "=SUMIF(E6,"">= 0"")"

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

أعتذر إليك أخي إذا كانت جملة "بدون الإطلاع على المرفق" قد أزعجتك .. ولكن هل تعلم إذا كان لدي وقت لأقوم بالإطلاع بالتفصيل على كل الموضوعات التي تطرح بالمنتدى أم لا .. أحببت أن أجعل الموضوع نشط غير خامل فاقترحت فكرة ربما تفيدك .. أو ربما تكون الفكرة مفتاح للحل يمكن أن يقدمه شخص آخر عموماً أعتذر على تطفلي بالموضوع تقبل تحياتي

أخي العزيز سامح لم تحدد في أي سطر ظهر الخطأ . عند حدوث خطأ تظهر رسالة فيها كلمة Debug انقر عليها ليتم تحديد السطر الذي به الخطأ باللون الأصفر عموماً أعتقد أن المشكلة في الكود هي استخدامك للفاصلة المنقوطة في المعادلة ..جرب تغيرها إلى فاصلة عادية وشوف هتظبط معاك أو لا .. أمر آخر علامات التنصيص في المعادلة توضع بين علامتي تنصيص أخرى لتصبح بهذا الشكل """" تقبل تحياتي

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

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

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

أخي الكريم محمود م ن يرجى تغيير الـ م ن في لقبك بلقبك الحقيقي ليعبر عن شخصكم الكريم جرب التعديل البسيط جداً في الكود الرائع لأخونا الغالي رجب Sub Ragab() Dim X As Integer Dim T As Variant Dim S_Name As Range If MsgBox("هل تريد تنفيذ الأمر؟", vbYesNo) = vbYes Then For Each T In Array("عام", "خاص", "مغلق", "مفتوح") On Error Resume Next With Sheets(T) Set S_Name = .Columns(2).Find(What:=[D5], LookAt:=xlWhole) X = Application.WorksheetFunction.Match(T, [C8:C11], 0) + 7 .Cells(S_Name.Row, 3) = Cells(X, 4) End With Next T Else MsgBox "لم يتم تنفيذ الأمر .. تم إلغاء العملية", 64 End If End Sub تقبل تحياتي

بسم الله ما شاء الله عليك عيني عليك باردة .. شكلك النهاردة هتاخد عين بس ما قولكش .. ربنا يستر عليك يا حوسو .. جزاكم الله خيراً على هذه الحلول الرائعة والممتعة .. تقبل تحياتي

أخي العزيز أحمد الفلاحجي لا تعلم مدى المعاناة التي عانيتها مع ملفاتك خصوصاً الملف المسمى "البيان" .. لا أعلم عندما قمت بعمل معاينة وجدت حوالي 1180 ورقة .. حاولت التخلص من البيانات الزائدة وعند حذف الأعمدة الزائدة يهنج الأوفيس ويغلق الملف وحاولت مراراً وتكراراً إلى أن تخلصت من هذه المشكلة وأبقيت على الأعمدة المطلوبة فقط في النطاق A1:Q عموماً جرب الكود التالي ..عله يفي بالغرض (رغم أن معادلاتك تعمل بشكل جيد كما لاحظت إلا أنني أفضل استخدام الأكواد نظراً لما تسببه المعادلات من ثقل في الملف خصوصاً مع البيانات الكثيرة) Sub ImportDataFromClosedWBUsingVLOOKUP() Dim WBK As Workbook Dim Rng As Range Dim LastRow As Long Dim I As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With ThisWorkbook.Sheets("Sheet1") Set WBK = Workbooks.Open(ThisWorkbook.Path & "\NewAll\7-2015.xlsx") Set Rng = WBK.Sheets("Sheet1").Range("G2:J" & Cells(Rows.Count, "G").End(xlUp).Row) LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("F3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",4,False),"""")" .Range("P3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",3,False),"""")" WBK.Close SaveChanges:=False '================================================================================================================ Set WBK = Workbooks.Open(ThisWorkbook.Path & "\NewAll\6-2015.xlsx") Set Rng = WBK.Sheets("Sheet1").Range("G2:S" & Cells(Rows.Count, "G").End(xlUp).Row) .Range("E3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",10,False),"""")" .Range("G3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",12,False),"""")" .Range("H3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",3,False),"""")" .Range("I3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",13,False),"""")" For I = 1 To 6 .Cells(3, I + 9).Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP($A3," & Rng.Address(, , , True) & "," & I + 3 & ",False),"""")" Next I .Range("Q3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",11,False),"""")" .Range("E3:Q" & LastRow).Value = .Range("E3:Q" & LastRow).Value WBK.Close SaveChanges:=False End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub وإليك الملف المرفق فيه تطبيق للكود وتم ضبط الملف الرئيسي "البيان" وجعلته بعنوان جديد (يمكنك تغيير اسمه لاسم "البيان" مرة أخرى ..لن يؤثر على عمل الكود) تقبل تحياتي Import Data From Closed Workbooks Using VLOOKUP Flahgy.rar

أخي الكريم أحمد الملف منذ أمد بعيد .. منذ بداياتي في الإكسيل .. نعرف إنه مش موجود عندي في مكتبتي الخاصة (جزاكم الله خيراً على الهدية) قم بوضع المعادلة التالية في الخلية Q2 =C2 وفي الخلية Q3 ضع معادلة الصفيف التالية (يتم الضغط على Ctrl + Shift + Enter بعد إدخال المعادلة) =IF(Q2="","",INDEX(C3:C$14,MIN(IF(COUNTIF(Q$2:Q2,C3:C$13),ROW(A$14)-ROW()+1,ROW(C3:C$13)-ROW()+1)))) ثم قم بسحب المعادلة إلى آخر خلية Q13 ستظهر في النتائج أصفار للتخلص منها قم بتحديد العمود Q بالكامل ثم كليك يمين ثم Format Cells ثم اختر الأمر Custom واكتب في الصندوق المسمى Type 0;-0;;@ ... قم بالدخول إلى التبويب Formulas ثم Name Manager ثم انقر الأمر New ثم اكتب اسم للنطاق وليكن UniqueList واكتب المعادلة التالية : =OFFSET(السجل!$Q$2,,,SUM(--(السجل!$Q$2:$Q$13<>0))) أخيراً روح للتبويب Data ثم Data Validation واختر List ثم في الحقل المسمى Source اضغط F3 من لوحة المفاتيح لتظهر لك النطاقات المسماة ..اختر منها النطاق UniqueList .. أرجو أن تكون الخطوات واضحة تقبل تحياتي

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

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

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