نجوم المشاركات

أخي الكريم أهلا بك ومرحباُ في المنتدى يرجى الإطلاع على التوجيهات من هذا الرابط كما يرجى تغيير اسم الظهور للغة العربية يرجى إرفاق ملف بعد ضغطه للإطلاع عليه ومحاولة مساعدتك إن شاء الله يمكنك الإطلاع على هذا الملف عله يفيدك الكود المرفق بالملف يقوم بتجميع البيانات من أوراق عمل محددة مسبقاً داخل الكود Collect Data From Sheets.rar

أرجوا أن ينال رضا الجميع وكل عام وأنتم بخير تقبلوا خالص تحياتى Excel Formulas.rar

أخوتى وأساتذتى ياسر فتحى وياسر خليل و سليم حاصبيا بارك الله فيكم وجازاكم خيرا أخى وأستاذى ياسر خليل بدون مجاملات الأكواد المضافة أكثر من رائعة وغاية فى الرقى وأنت من علمنى الحرص على أن يكون الكود يجمع بين البساطة والدقة والسرعة والمرونة والاختصار جازكم الله عنى وعن تلاميذك خيراً واليك هذه الاضافة أيضا تؤدى نفس الوظيفة بدون اللجوء إلى استخدام طريقة النسخ كما هو الحال فى كودك الثانى بالمشاركة 4 Sub mokhtest3() Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Value = Sheets("بيانات").Cells(ActiveCell.Row, 1).Resize(1, 6).Value End Sub تحياتى

الأخوة والأساتذة الكرام طلب أحد الأخوة نسخ الخلية النشطة مع صفها من شيت الى شيت آخر فى هذا الرابط http://www.officena.net/ib/index.php?showtopic=62805 ولعموم الفائدة أضع بين أيديكم كود نسخ الخلية النشطة وبعدها عدد محدد من الخلايا وليكن 5 خلايا مثل النسخ من A5 الى F5 Sub mokhtest2() Application.ScreenUpdating = False ActiveCell.Resize(1, 6).Copy Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) ' لنسخ ولصق النشطة بالفورمات وبعدها 5 خلايا Application.ScreenUpdating = True Application.CutCopyMode = False End Sub الجزئية ActiveCell.Resize(1, 6).Copy معناها نسخ الخلية النشطة مع 5 خلايا بعدها فى نفس الصف وده = 6 الجزئية Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) هى وجهة اللصق أول فارغة فى العمود 1 فى الشيت مستودع واللصق يكون للقيم والفورمات باقى الكود للتسريع وتفريغ الذاكرة العشوائية المرفق copy row based on ActiveCell mokhtar .rar

ما شاء الله تبارك الله اخي ياسر دائما مثل الشمعة التي تحترق لتظيئ الطريق

مبدع ... كعادتك

هل قمت بتغيير اسم المصنف الذي يتم جلب البيانات منه كما في الكود ... شوف اسم المصنف عندك وعدل في الكود بالاسم في السطر Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "Data Base.xlsx") يعني شوف اسم المصنف ايه اللي إنت بتاخد منه البيانات وعدل هذا السطر بما يناسب اسم ملفك

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

السلام عليكم أخى الكريم فتحى سلام .. لا أدرى إصرارك على ترك الملف فارغ من البيانات هل يمكن تحويل المعادلات الى أكواد ؟ نعم يمكن ذلك.. وفر قدر مناسب من البيانات فى الملف حتى يتم التحقق من النتائج .. لا تطلب منا وضع بيانات افتراضية من لدينا عليك بوضع قدر مناسب من البيانات يمكن فى ضوئه تحويل المعادلات لأكواد و التأكد من النتائج .. على هامش الموضوع : لقد أثرت ضحكى من عنوان موضوعك و لمحت أسمك ففهمت المطلوب قبل أن أفتح الملف و لكن مازاد ضحكى أكثر هو ان الملف فارغ من البيانات كأن المعادلات ستعمل دون بيانات .. أساسيات الحاسب تقول بيانات + تشغيل ( معادلات أو أكواد ) = معلومات وضعك الحالى تشغيل ( معادلات أو أكواد ) = لا شئ أنت تجعلنا ندور فى دائرة مفرغة .. تشعرنى أنك لا تقرأ تعقيبات أحد عموما دمت بخير و أعزك الله

السلام عليكم ألف مبروك ، و نبارك أيضا لباقي الأخوة و نعتذر لتأخير الترقيات خلال الفترة الماضية

الفكرة رائعة جدا أنا بصراحه معجب بيها وب ادرسها لان فيها شغل عالي جزاك الله خيرا ا / ياسر حبيب قلبي

أخي الكريم مجدي الطيب جرب الكود التالي (قمت بتغيير اسم المصنف للغة الإنجليزية ..يمكنك تسميته باللغة العربية وتعديل الاسم في الكود ..فقط لسهولة التعامل مع الكود قمت بتغيير اسم المصنف ) Sub ImportData() Dim WB As Workbook, rngLookup As Range Dim myRow As Long Dim shMain As Worksheet Application.ScreenUpdating = False Set shMain = ThisWorkbook.ActiveSheet Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "Data Base.xlsx") Set rngLookup = WB.ActiveSheet.Range("B3:B" & WB.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row) On Error Resume Next With shMain myRow = Application.WorksheetFunction.Match(.Range("B1"), rngLookup, 0) + 2 Union(.Range("C8"), .Range("K8"), .Range("D11"), .Range("C14"), .Range("G14"), .Range("K14")).ClearContents .Range("C8") = WB.ActiveSheet.Cells(myRow, "C") .Range("K8") = WB.ActiveSheet.Cells(myRow, "E") .Range("D11") = WB.ActiveSheet.Cells(myRow, "D") .Range("C14") = WB.ActiveSheet.Cells(myRow, "F") .Range("G14") = WB.ActiveSheet.Cells(myRow, "G") .Range("K14") = WB.ActiveSheet.Cells(myRow, "H") End With WB.Close False Application.ScreenUpdating = True End Sub لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" إذا نالت المشاركة إعجابكم تقبل تحياتي Import Data From Closed Workbook.rar

جرب هذا الملف و يمكن استعمال معادلاته في User Form conditional sum.zip

ررررررررررررررررائع بارك الله فيك

مشكور على مرورك العطر بالموضوع أخي وحبيبي في الله أبو يوسف بارك الله فيك وجزيت خير الجزاء

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

تحياتى لك

مشكور أخى ياسر على الهدية القيمة والجميلة أيضا بارك الله فيك وجزاك الله خير الجزاء

رائع

بارك الله فيك

أخى الحبيب ياسر فتحى بارك الله فيكم وجازاكم عنا خيرا

تسلم ايديك اخى الحبيب ملف رائع

رائع للغاية و سهل جدا متميز جدا أخى الكريم .. دمت بخير و أعزك الله .

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

هدية تعبر عن صاحبها دائما مبدع كل عام وانتم بخير

اخواني في المنتدى لماذا لا تدعون المستخدم يختار عدد الصفوف و الاعمدة المطلوبة ابتذاءً من الخلية المحددة (بدل ان يدخل الى الكود و يقوم بهذا الشيء) عبر هذا الكود Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet, LR As Long Set WS = Sheets("Sheet1"): Set SH = Sheets("Sheet2") LR = SH.Cells(Rows.Count, 1).End(xlUp).Row myrow = Application.InputBox("حدد عدد الصفوف", Default:=1) mycol = Application.InputBox("حدد عدد الاعمدة", Default:=1) ActiveCell.Resize(myrow, mycol).Copy SH.Cells(LR + 1, 1).PasteSpecial (xlValues) Application.CutCopyMode = False End Sub

جزاك الله كل خير

مشكور على الهدية القيمة بارك الله فيك وجزاك الله خير الجزاء

جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("g14")) Is Nothing Then m = Target.Value n = Target.Offset(1, 0).Value + m Target.Offset(1, 0) = n Target.Value = "" Target.Select Application.EnableEvents = True End If Application.EnableEvents = True End Sub

بارك الله فيك أخي الحبيب مختار إليك كود آخر لا يرقى لمستوى كودك بالطبع ..فكودك هو الأيسر والأسهل Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet Dim lrWS As Long, lrSH As Long, I As Long Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع") lrWS = ActiveCell.Row lrSH = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1 For I = 1 To 6 SH.Cells(lrSH, I) = WS.Cells(lrWS, I) Next I End Sub

اخى محمد بالفعل الكود الذى تفضلت به صحيح ويمكن ايضا مسح الخليه دون التحديد Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("g14:g14")) Is Nothing Then Target.Offset(1, 0).Value = Target.Value + Target.Offset(1, 0).Value Range("G14").ClearContents End If End Sub او Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("g14:g14")) Is Nothing Then Target.Offset(1, 0).Value = Target.Value + Target.Offset(1, 0).Value Target.Value="" End If End Sub تقبل تحياتى

وعليكم السلام وررحمة الله وبركاته اخى محمد ضع هذه الكود فى حدث الورقه Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("G14:G14")) Is Nothing Then Target.Offset(1, 0).Value = Target.Value + Target.Offset(1, 0).Value End If End Sub تقبل تحياتى

الله يبارك فى اخى الحبيب ده من ذوقك واخلاقك والف مليون مبروك على ترقيتك انت ايضا وانت تستحق هذه الترقيه انت فعلا متميز وان شاء الله نفرح بترقيه اعلى لك تقبل تحياتى وتقديرى

السلام عليكم الموضوع له علاقة بتنسيق تلك الاعمدة فى حدث كود الترحيل والتعديل تفضل المرفق وابدى ملاحظاتك اذون صرف_قبض_ _PASS 111_ضاحى.rar

عموماً إليك الكود التالي عله يفي بالغرض إن شاء المولى Sub Test() Dim Coll As New Collection, ArrSheet, ArrTemp, ArrHolder, ArrOut1, ArrOut2 Dim I As Long, J As Long, P As Long, P1 As Long, P2 As Long, Str1 As String ArrSheet = Array(Sheets("مباع"), Sheets("مفعل"), Sheets("active"), Sheets("راجع")) ReDim ArrHolder(1 To Rows.Count, 1 To (UBound(ArrSheet) + 2)) ReDim ArrOut1(1 To Rows.Count, 1 To 1) ReDim ArrOut2(1 To Rows.Count, 1 To 1) For J = LBound(ArrSheet) To UBound(ArrSheet) ArrTemp = ArrSheet(J).Range("A2").CurrentRegion.Columns(1).Value On Error Resume Next For I = 1 To UBound(ArrTemp, 1) Str1 = CStr(ArrTemp(I, 1)) Coll.Add Key:=Str1, Item:=Coll.Count + 1 P = Coll(Str1) ArrHolder(P, 1) = ArrTemp(I, 1) ArrHolder(P, J + 2) = ArrHolder(P, J + 2) + 1 Next I On Error GoTo 0 Next J For I = 1 To Coll.Count P = 0 For J = 2 To UBound(ArrHolder, 2) P = P + Sgn(ArrHolder(I, J)) Next J If (P = UBound(ArrSheet) + 1) Then P1 = P1 + 1 ArrOut1(P1, 1) = ArrHolder(I, 1) Else P2 = P2 + 1 ArrOut2(P2, 1) = ArrHolder(I, 1) End If Next I With Sheets("النتيجة المطلوبة") .Range("A2").Resize(P1).Value = ArrOut1 .Range("B2").Resize(P2).Value = ArrOut2 End With End Sub سيتم استخراج الأرقام المتشابهة في كل أوراق العمل الأربعة معاً في العمود الأول أما الأرقام التي لم تحقق الشرط ستكون في العمود الثاني في ورقة العمل الأخيرة لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" في حالة أن أعجبك الحل تقبل تحياتي Similar Data In Multi Sheets YasserKhalil.rar

أخي الكريم أبو حنين لا أدري هل تريد تنفيذ السطر قبل تحويل الملف لـ PDF أم بعد التحويل .. عموماً إذا كنت تريد الرسالة في بداية الكود قبل تحويل الملف لـ PDF فيمكنك ببساطة إضافة السطر التالي بعد المتغيرات If MsgBox("هل تريد إرسال الملف المرفق إيميل أم لا؟", vbYesNo, "Send Email") = vbNo Then Exit Sub أما إذا كنت تريد أن تتم عملية التحويل إلى PDF أولاً ثم السؤال عن إرسال الملف من عدمه فيمكنك استخدام نفس السطر لكن في مكان آخر داخل الكود بهذا الشكل Sub PDF() Dim MyName As String MyName = "D:\Drivers Tarek\PDF\Drivers_" & Format(Date + 1, "dd-mm-yyyy") & ".pdf" Range("B5").Select Range("B5").Select Sheets(Array("حركة")).Select Sheets("حركة").Activate MyMsg = MsgBox("هل أنت متأكد من اتمام عمليه الحفظ", 4, "تنبيه") If MyMsg = 6 Then ChDir "D:\Drivers Tarek" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ MyName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False If MsgBox("هل تريد إرسال الملف المرفق إيميل أم لا؟", vbYesNo, "Send Email") = vbNo Then Exit Sub OutlMail_PDF MyName, "ahmed@yahoo.com", " بيان بحركة السائقين ", vbNewLine & "مع تحيات ..إدارة الشئون الادارية بحقول طارق", False Else MsgBox "لم يتم الحفظ" End If Sheets("حركة").Select ActiveWindow.SmallScroll Down:=-12 Range("B5").Select End Sub أرجو أن يكون في هذا السطر حل لمشكلتك إن شاء المولى عزوجل

افس 2007 واعلى تروح ايقونه الافس بالزاوايه يمين اعلى خيارات ثم خيارات متقدمة تم تنزل اسفل فيه خانة اسمها ( تحديث الارتباطات الى مستندات اخرى ) شيل علامة الصح بالمربع ان شاء الله يكون هذا السبب بالمشكلة

الأخ الفاضل غسان العبيدى عمل جميل وفكرة جيدة واسمح لى ان اضيف عليها طلب الاخ الفاضل الميسانى وهو نفس الفورم السابقة مع اضافة 1- عنوان ثابت 2- مربع ادخال نص متغير العرض 3- زر تمرير متغير الارتفاع 4- بالاضافة الى تعديل صورة الخلفية 5- ايضا هناك إضافة صغيرة للتحكم فى الحد الادنى لأبعاد الفورم Resize Userform تغيير حجم اليوزرفورم بالماوس.rar

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

إخوانى فى الله الأستاذ الكريم // عماد أبو خلف الأستاذ الكريم // محمد الريفى الأستاذ الكريم // أبو بهاء المصرى الأستاذ الكريم // حسام عيسى الأستاذ القدير // أبو محمد عباس الأستاذ الكريم // محمد الخازمى الأستاذ القدير // ياسر خليل الأستاذ الكريم // أبو صلاح الأستاذ الكريم // محمود على محمود الأستاذ الكريم // زيزو العجوز بارك الله فيكم على مروركم الكريم وثناؤكم على الموضوع وتقبلوا منى وافر الإحترام والتقدير

السلام عليكم المصفوفات الجداول تعريف مبسط : التعامل مع اكثر من قيمة واحدة تطبيقات عملية الدرس الاول : المصفوفات Arrays rArr = Array("A", "B", "C") اذا اردنا ان نضع الصفيف هذا على صف واحد وثلائة اعمدة Sub kh_1() Dim rArr rArr = Array("A", "B", "C") Range("A1").Resize(1, 3).Value = rArr End Sub اذا اردنا ان نضع الصفيف هذا على ثلاثة صفوف وعمود واحد تعرفون الدالة TRANSPOSE إرجاع نطاق خلايا عمودى كنطاق أفقي، أو بالعكس. يجب إدخال TRANSPOSE كصيغة صفيف في نطاق به نفس عدد الصفوف والأعمدة، على الترتيب، مثل صفيف الأعمدة والصفوف الخاصة به. استخدم TRANSPOSE لتبديل الاتجاه العمودي والأفقي لصفيف في ورقة عمل. بناء الجملة TRANSPOSE(array) Array (الصفيف) هو الصفيف أو نطاق الخلايا في ورقة العمل التي ترغب في تحويلها. يتم إنشاء تحويل الصفيف باستخدام الصف الأول للصفيف على أنه العمود الأول للصفيف الجديد، والصف الثاني للصفيف على أنه العمود الثاني للصفيف الجديد، وهكذا. ============================================================ Sub kh_2() Dim rArr rArr = Array("A", "B", "C") rArr = WorksheetFunction.Transpose(rArr) Range("A1").Resize(3, 1).Value = rArr End Sub يتبع لمتابعة الموضوع افضل ان تضعوا هذه الاكواد في ملف الان نقوم باضافة فورم ونضيف التالي ListBox1 CommandButton1 CommandButton2 اضف هذه الاكواد للفورم Private Sub CommandButton1_Click() Dim rArr rArr = Array("A", "B", "C") Me.ListBox1.List = rArr End Sub Private Sub CommandButton2_Click() Dim rArr rArr = Array("A", "B", "C") Me.ListBox1.Column = rArr End Sub Private Sub UserForm_Initialize() Me.ListBox1.ColumnCount = 3 End Sub بعد فتح الفورم اضغط على الازرار CommandButton1 CommandButton2 ما هي النتيجة يتبع ============================================================= المصفوفة Array("A", "B", "C") من النوع Variant وذو البعد الواحد واول دليل لعناصرها LBound صفر وآخر دليل لعناصرها UBound عدد عناصرها ناقص واحد ونضيف عناصرها دفعة واحدة ============================================================= بعض الدالات للسلاسل النصية تعطي نتائج صفيف مثل SPLIT FILTER ناخذ مثال عن SPLIT Sub kh_Split() Dim MyAr MyAr = Split("عبدالله علي احمد باقشير") Range("A1").Resize(1, UBound(MyAr) + 1).Value = MyAr End Sub =========================================================== =========================================================== =========================================================== الدرس الثاني : الجداول المفهرسة عبارة عن متغيرات مفهرسة Indexed Variables تحتوي على بيانات عديدة من نفس النوع Data Type . كل مصفوفة لها اسم واحد يمكن استخدامه للرجوع إلى أي عنصر فيها وذلك باقتران هذا الاسم بدليل يمثل مكان العنصر فيها ، ويمكن انشاء مصفوفة لإحتواء أي نوع من أنواع البيانات مثل : النصوص والأعداد الحقيقية و الصحيحة وغيرها ، فأنواع البيانات المتوفرة في الفيجيوال بيسك هي : Data Type in VB: {Byte, Boolean, Integer, Long, Single, Double, Currency, Decimal, Date, Object, String, Variant, User-defined }. واستخدام المصفوفات في البرمجة يساعد في صناعة أكواد قصيرة وبسيطة ذات قوة كبيرة لأنه يمكن بناء Loops تتعامل بكفاءة مع المصفوفات مهما كان عدد عناصرها وذلك باستخدام دليل العنصر Index Number . ================================================= الخصائص الأساسية للمصفوفة في الفيجيوال بيسك : اسم المصفوفة يمثل عنوان Address في الذاكرة ؛ ولا يمكن تغييره أثناء تنفيذ البرنامج . يمكن الإعلان عن مصفوفة لأي نوع من أنواع البيانات بما في ذلك الأنواع المعرفة من قبل المستخدم User-defined type والـ Object Variables . كل وحدة بيانات منفردة في المصفوفة تسمى عنصر Element . جميع العناصر تكون من نفس النوع إلا في حالة الإعلان عن المصفوفة كـ Variant Data Type . جميع العناصر تكون مخزنة على التتابع في ذاكرة الحاسوب ودليل أول عنصر هو الصفر كـ Default ويمكن جعله 1 باستخدام جملة في بداية الوحدة النمطية Option Base 1 لكل مصفوفة حداً أعلى Upper bound ، وحداً أدنى Lower bound ؛ وعناصر المصفوفة تكون محصورة بين هذين الحدين . من الممكن أن تكون المصفوفة ذات بعد واحد أو متعددة الأبعاد . تحديد الحدين الأعلى والأدنى للمصفوفة Upper bound & Lower bound: عند الإعلان عن مصفوفة، يكتب الحد الأعلى بعد الاسم وبين الأقواس. لا يمكن أن يزيد الحد الأعلى عن نطاق نوع المتغير Long Data Type. الحد الأدنى الإفتراضي Default هو الصفر. اذا عرفت عن هذا المتحول بـــــ Limiteinf To LimiteSup في مكان الوسيط Indexs تكون قد عرفت جدولا بعدد عناصر محدد وبارقام دليل محددة وهذه الطريقة افضل للاستخدام للفهم السريع للوسيط Indexs Dim ay(1 To 3, 1 To 2) As String ----------------------------------------------------------------------------- ay(1 To 3, 1 To 2) لمعرفة الدليل الاول والاخير لليعد الملون بالاحمر للمتحول LBound(ay, 1) UBound(ay, 1) لمعرفة الدليل الاول والاخير للبعد الملون بالازرق للمتحول LBound(ay, 2) UBound(ay, 2) ================================================================== ================================================================== ملحوظة عند إضافة أبعاد المصفوفة فإن مساحة التخزين المطلوبة سوف تزيد زيادة كبيرة ولذلك ينبغي الاحتراس وتفادي استخدام النوع Variant قدر الإمكان لما يتطلبه من مساحة تخزينية كبيرة! ================================================================== ================================================================== المصفوفة ذات الحجم الثابت نعلن عنها بأحد أوامر الإعلان (Public or Private or Dim or Static) مع تحديد عدد العناصر في الأقواس Dim ay(1 To 3, 1 To 2) As String مثال 1: Sub kh_Array1() Dim ay(1 To 3, 1 To 2) As String ay(1, 1) = "A" ay(2, 1) = "B" ay(3, 1) = "C" ay(1, 2) = "D" ay(2, 2) = "E" ay(3, 2) = "F" Range("A1").Resize(3, 2).Value = ay End Sub مثال 2 جدول ضرب Sub KH_5() Dim sArr(1 To 12, 1 To 10) As Integer Dim ContRow As Integer, ContColmn As Integer Dim c As Integer, r As Integer ContRow = UBound(sArr, 1) ContColmn = UBound(sArr, 2) For r = 1 To ContRow For c = 1 To ContColmn sArr(r, c) = r * c Next Next Range("A1").Resize(ContRow, ContColmn).Value = sArr End Sub المصفوفات متغيرة الحجم Dynamic Array: في بعض الأحيان، لا نعرف مسبقاً حجم المصفوفة التي سنستخدمها في البرنامج بالضبط، وقد نريد تغيير حجم المصفوفة أثناء تشغيل البرنامج، هنا سنحتاج إلى المصفوفات ذات الحجم المتغير Dynamic حيث يمكننا تغيير حجمها في أي وقت. تعتبر المصفوفات متغيرة الحجم أحد مميزات الفيجيوال بيسك، وهي تساعد في تنظيم الذاكرة بكفاءة. فمثلاً، يمكن استخدام مصفوفة كبيرة لوقت قصير ثم إعادة تحجيمها لتحرير مساحة من الذاكرة عندما لا نحتاجها. وهذا من شأنه تسريع المعالجة. ولصناعة Dynamic Array نتبع التالي: نعلن عنها بأحد أوامر الإعلان (Public or Private or Dim or Static) ونجعلها ديناميكية بعدم كتابة أي رقم في الأقواس كما يوضح المثال التالي: Dim sArr() As String نعيد الإعلان عنها مع تحديد عدد العناصر باستخدام جملة ReDim كما في المثال التالي: ReDim sArr(1 To ContRow, 1 To ContColmn) ================================================================== ================================================================== ملاحظات هامة . كل جملة من جمل ReDim يمكنها تغيير عدد العناصر بالإضافة إلى الحد الأعلى والحد الأدنى لكل بعد للمصفوفة، ومع ذلك فإن عدد الأبعاد في المصفوفة لا يمكن تغييره. . تمحى جميع القيم المخزنة في المصفوفة كل مرة يعاد فيها تنفيذ جملة ReDim. ويجعل الفيجيوال بيسك القيم كالتالي: في حالة الــــ Variant Array --------- الى ----- Empty Value في حالة الــــ Numeric Array ------- الى ----- Zero في حالة الــــ String Array ----------- الى ----- Zero-Length String في حالة الــــ Array of objects ------ الى ----- Nothing وهذا مفيد عندما نريد تجهيز المصفوفة لبيانات جديدة أو عندما نريد اختزال حجم المصفوفة لتأخذ أقل مساحة ممكنة في الذاكرة. ================================================================== ================================================================== مثال 1: Sub KH_6() Dim sArr() As String Dim iName As String Dim ContRow As Integer, ContColmn As Integer Dim c As Integer, r As Integer, i As Integer Range("H7").Resize(14, 5).ClearContents iName = CStr([H4]) ContColmn = 5 With Range("B7").Resize(14, 1) ContRow = WorksheetFunction.CountIf(.Cells, iName) ReDim sArr(1 To ContRow, 1 To ContColmn) For r = 1 To .Rows.Count If CStr(.Cells(r, 1)) = iName Then i = i + 1 For c = 1 To ContColmn sArr(i, c) = CStr(.Cells(r, c)) Next End If Next End With Range("H7").Resize(ContRow, ContColmn).Value = sArr Erase sArr End Sub دروس المصفوفة 1.rar ================================================================== ================================================================== Erase تستخدم لتحرير الذاكرة المعينة للجداول الديناميكية واعادة تعيين عناصر الجدول الى قيمتها البدائية بطول ثابت مثال: Erase sArr ================================================================== ================================================================== تغيير حجم المصفوفة دون فقد بياناتها يمكننا فعل ذلك باستخدام جملة ReDim مع كلمة Preserve وتعني الحفظ الجملة التالية تغير حجم المصفوفة ولكنها لا تمحو العناصر الموجودة بها: ReDim Preserve MyArray( 10 ) والآن يمكننا كتابة ملخص متكامل لجملة ReDim. جملة ReDim: تستخدم في مستوى الـProcedure لإعادة تخصيص allocates مساحة تخزينية storage space لمصفوفة متغيرة الحجم Dynamic array. صيغتها Syntax: ReDim [Preserve] varname(subscripts) [As type] [, varname (subscripts) [As type]] ================================================================== ================================================================== ملاحظات هامة: جميع ما ذكر في الصيغة داخل قوسين مربعين [] يعتبر اختياري يمكن الاستغناء عنه حين عدم الحاجة إليه. تستخدم جملة ReDim لتحجيم أو إعادة تحجيم مصفوفة متغيرة الحجم Dynamic Array والتي بالفعل قد أعلن عنها مسبقاً باستخدام أي من الجمل Dim, Private, Public مع أقواس فارغة (أي بدون ذكر الأبعاد). يمكن تكرار استخدام جملة ReDim لتغيير عدد العناصر والأبعاد لمصفوفة، ومع ذلك لا يمكن الإعلان عن مصفوفة بنوع معين من البيانات ثم إعادة تعريفها لاحقاً مع تغيير نوع البيان لنوع آخر إلا إذا كانت المصفوفة محتواه في variant. إذا كانت المصفوفة محتواه في variant فإن نوع بيان العناصر يمكن أن يتغير باستخدام المقطع As Type إلا إذا استخدمنا كلمة Preserve ففي هذه الحالة لا يسمح بتغييرات. إذا استخدمنا كلمة Preserve يمكن فقط تحجيم البعد الأخير للمصفوفة ولا يمكن تغيير عدد الأبعاد على الإطلاق. إذا كان للمصفوفة بعد واحد فيمكن إعادة تحجيم هذا البعد لأنه البعد الأخير والوحيد بالمصفوفة. وإذا كان للمصفوفة بعدين أو أكثر فيمكن فقط تغيير حجم البعد الأخير مع الاحتفاظ بمحتويات المصفوفة. عندما نستخدم Preserve يمكن تغيير حجم المصفوفة بتغيير الحد الأعلى بينما ينتج لدينا خطأ حين تغيير الحد الأدنى. إذا صنعنا مصفوفة أصغر مما كانت فإن بيانات العناصر المخزنة سوف تفقد. تحذير: جملة ReDim ستعمل وكأنها جملة إعلان إذا كان المتغير (المصفوفة) التي تعلن عنه غير موجود على مستوى الـProcedure أو الـModule. وإذا كان هناك متغير آخر بنفس الاسم قد أنشئ بعد ذلك وحتى لو كان في النطاق ككل Scope؛ فإن ReDim سوف ترجع للمتغير الأخير ولن يتسبب عن ذلك خطأ في الترجمة Compilation error حتى ولو كانت جملة Option Explicit فعّالة. وبذلك لن يدرك المبرمج أنه هناك خطأ بالشيفرة code. ولتفادي هذا التعارض لا ينبغي استخدام جملة ReDim كجملة إعلان بدلاً من Dim مثلاً، ولكن نستخدمها فقط لإعادة تعريف حجم المصفوفة. ================================================================== ================================================================== توضيح اكثر لهذه الملاحظة إذا استخدمنا كلمة Preserve يمكن فقط تحجيم البعد الأخير للمصفوفة ولا يمكن تغيير عدد الأبعاد على الإطلاق. امثلة : للبعد الاخير ( الملون بالاحمر) هنا ثلاثة ابعاد البعد الاخير هو 15 ReDim Preserve X(10,12,15) ReDim Preserve X(10,12,15) هنا بعدين البعد الاخير هو 12 ReDim Preserve X(10,12) ReDim Preserve X(10,12) هنا بعد واحد إذا كان للمصفوفة بعد واحد فيمكن إعادة تحجيم هذا البعد لأنه البعد الأخير والوحيد بالمصفوفة ReDim Preserve X(10) ReDim Preserve X(10) حمل الملف الموجود في هذا الموضوع تطبيق عملي لما ذكر اعلاه http://www.officena....showtopic=42346 http://www.officena.net/ib/index.php?showtopic=42584 دروس المصفوفة 1.rar kh_SumProduct.rar دروس المصفوفة ( دالة لتوليد ارقام عشوائية).rar ((الشرح العلمي منقول من هنا وهناك)) تم بحمد الله وشكره