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

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

أخي الكريم قم بعمل كليك يمين على اسم ورقة العمل المطلوب النتائج فيها ثم اختر View Code ثم ضع الكود .. وفقط

السلام عليكم أخي الكريم جرب الكود التالي في حدث ورقة العمل .. المسماة "TABLEAU" Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$G$1" Then Dim ws As Worksheet Dim sh As Worksheet Dim c As Range Dim cc As Range Set sh = Sheets("TABLEAU") Application.ScreenUpdating = False For Each c In sh.Range("A9:A11") For Each ws In ThisWorkbook.Worksheets If InStr(ws.Name, c.Value) > 0 Then For Each cc In ws.Range("B5:B" & ws.Cells(Rows.Count, 2).End(xlUp).Row) If cc.Value = sh.Range("C5").Value Then c.Offset(, 1).Resize(1, 5).Value = cc.Offset(, 1).Resize(1, 5).Value Exit For Else c.Offset(, 1).Resize(1, 5).Value = "" End If Next cc End If Next ws Next c Application.ScreenUpdating = True End If End Sub

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

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

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

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

السلام عليكم جرب الكود التالي عله يفي بالغرض .. وأعتذر أني وعدتك فنسيت ولكن يجب متابعة الموضوع بالردود لكي يظهر الموضوع في أول صفحة بالمنتدى وأستطيع رؤيته .. عموماً حصل خير Sub CollectFromMultipleSheets() Dim wb As Workbook Dim wsTarget As Worksheet Dim wsSource As Worksheet Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long Dim x As Long Application.ScreenUpdating = False Set wsTarget = ThisWorkbook.Worksheets("Feuil1") Set wb = Workbooks.Open(ThisWorkbook.Path & "\listeleve.xls") cr = Array(2, 3, 4, 5, 6, 7, 8) wsTarget.Range("B10").Resize(, 7).Value = Array("ر.ت", "الرمز", "النسب", "الاسم", "النوع", "تاريخ الازدياد", "مكان الازدياد") For Each wsSource In wb.Worksheets lr = wsSource.Cells(Rows.Count, "F").End(xlUp).Row arr = wsSource.Range("C16:AA" & lr).Value x = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1 j = 0 For Each i In Array(25, 22, 15, 11, 10, 4, 1) wsTarget.Cells(x, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) j = j + 1 Next i Next wsSource wb.Close False Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub

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

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

وعليكم السلام أخي الكريم زهير لربما تقصد إلى VCF وليس CSV ..جرب الملف التالي عله يفي بالغرض .. وإذا لم يفي بالغرض قم بإرفاق ملفك Convert Excel Contacts To VCF YasserKhalil Officena.rar

وجزيت خيراً أخي العزيز ناصر والحمد لله أن استطعت تنفيذ الشرح

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

وعليكم السلام أخي الكريم محمد سامر أهلاً بك في المنتدى ونورت بين إخوانك الرجاء التماس العذر لإخوانك فالجميع هنا لا يتأخر عن تقديم المساعدة ولكن حينما يتيسر الوقت لهم .. فالرجاء الصبر .. إليك خطوات الحل بالتنسيق الشرطي (وقد استخدمه الأخ سليم بمعادلة أخرى .. ولكني استخدمت معادلة أسهل في الفهم لك) وإليك الملف المطبق فيه الخطوات السابقة مع شرح لكيفية الاستفادة من الجدول المساعد لتفهم كيف تم الأمر Conditional Formatting Using OR Tutorial YasserKhalil Officena.rar

هذه الحلقة فيها شرح كافي ووافي إن شاء الله لموضوع الفرز

بعد محاولة فهم المطلوب .. إليك الكود التالي عله يفي بالغرض قم أولاً في الملف المرفق الأخير بتسمية الشيت باسم Sheet1 وأنشيء ورقة عمل جديدة باسم Sheet2 .. ثم نفذ الكود التالي .. والنتائج ستكون منفصلة في ورقة العمل Sheet2 Sub TestArrays() Dim arr As Variant Dim temp As Variant Dim x As Variant Dim b As Boolean Dim f As Boolean Dim str As String Dim i As Long Dim j As Long Dim k As Long With Sheets("Sheet1") arr = .Range("A1:L" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) For i = LBound(arr, 1) To UBound(arr, 1) If InStr(arr(i, 1), "محافظة") > 0 And b = False Then For j = 1 To 5 str = str & "," & CStr(arr(i + 1, j)) Next j b = True i = i + 3 k = k + 1 For j = LBound(arr, 2) To 7 temp(k, j) = CStr(arr(i, j)) Next j x = Split(Mid(str, 2), ",") For j = LBound(x) To UBound(x) temp(k, j + 8) = x(j) Next j b = False: f = True: str = "" Else If b = False And f = False Then k = k + 1 For j = LBound(arr, 2) To UBound(arr, 2) temp(k, j) = CStr(arr(i, j)) Next j ElseIf b = False And f = True Then k = k + 1 For j = LBound(arr, 2) To 7 temp(k, j) = CStr(arr(i, j)) Next j For j = 8 To 12 temp(k, j) = temp(k - 1, j) Next j End If End If Next i Sheets("Sheet2").Range("A1").Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp MsgBox "Done...", 64 End Sub

أنتظر نموذج مصغر للعمل عليه لكي تتضح الصورة أكثر وسأحاول في الموضوع قدر استطاعتي

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

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

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

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

أخي الكريم شاهد الفيديو التالي أولاً وحاول بنفسك .. وإذا تعثرت في أمر ما اذكر ما تعثرت فيه وحاول دائماً أن ترفق الملف الذي تود العمل عليه ..

لم أفهم النقطة التي تتكلم فيها .. ملفات أخرى بأي شكل الكود يتعامل مع ملف مغلق تحدد اسمه ومساره .. هل تقصد هذه الطريقة ؟؟!! Private Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long Sub Test() Dim openFile As Variant Dim wbk As Workbook SetCurrentDirectoryA ThisWorkbook.Path & "\" openFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS*), *.XLS*", Title:="Select File To Be Opened") If openFile = False Then Exit Sub On Error Resume Next Set wbk = openFile If wbk Is Nothing Then Set wbk = Workbooks.Open(Filename:=openFile, ReadOnly:=True) If wbk Is Nothing Then MsgBox openFile & " Not Found!", vbCritical Exit Sub End If Else wbk.Activate ActiveWindow.WindowState = xlMaximized End If On Error GoTo 0 End Sub

السلام عليكم أخي صلاح جرب الكود التالي Sub OpenClosedWB() Const strInput As String = "123.xlsx" Dim wbk As Workbook On Error Resume Next Set wbk = Workbooks(strInput) If wbk Is Nothing Then Set wbk = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strInput, ReadOnly:=True) If wbk Is Nothing Then MsgBox strInput & " Not Found!", vbCritical Exit Sub End If Else wbk.Activate End If On Error GoTo 0 End Sub

أعتقد أنك تقصد النطاق Range("H12:H16") ستقوم بتغيير الرقم 16 إلى آخر رقم فيه بيانات أو .. استبدل هذا الجزء في الكود بهذا الجزء Range("H12:H" & Cells(Rows.Count,"H").End(XlUp).Row)