تغيير حجم المصفوفة ( ذات البعدين ) دون فقد بياناتها ( كود بحث )

[عبدالله باقشير]

السلام عليكم

مثال عملي

لتغيير حجم المصفوفة ( ذات البعدين ) دون فقد بياناتها

موضوع المصفوفات

http://www.officena....showtopic=42397

كود بحث

السطر هذا للاعلان عن المصفوفة

Dim MyAry() As String

السطر هذا للاعلان عن المصفوفة بعد تغيير البعد الاخير مع حفظ المخزون سابقا

ReDim Preserve MyAry(1 To 6, 1 To i)

اعادة تعيين عناصر الجدول الى قيمتها البدائية مع تحرير الذاكرة

Erase MyAry

ومن اجل وضع المصفوفة في الخلايا جعلنا صفوفها اعمدة واعمدتها صفوف استخدمنا الدالة Transpose

WorksheetFunction.Transpose(MyAry)

كود البحث

Option Explicit

'=============================================

'=============================================


Sub Kh_Find()

Static MySve As String

Dim MyAry() As String

Dim MyTextFind As Variant

Dim FirstAddress As String

Dim sFind As Worksheet

Dim sPast As Worksheet

Dim Cel As Range

Dim i As Long

Dim ii As Long


On Error GoTo 1

Set sPast = Worksheets("نتائج البحث")


With sPast

.Activate

.Range("A2").Select

.Range("A2").Resize(2, .UsedRange.Columns.Count).ClearContents

.Range("A4").Resize(.UsedRange.Rows.Count).EntireRow.Delete

End With


MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث", MySve, 100, 100, , , 2)

If MyTextFind = "" Or MyTextFind = False Then GoTo 2


Set sFind = Worksheets("البحث في المكتبة")

'====================================

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'====================================

With sFind.Range("C1:C65000")

Set Cel = .find(MyTextFind, LookIn:=xlValues)

If Not Cel Is Nothing Then

FirstAddress = Cel.Address

Do

ii = Cel.Row

If ii = 1 Then GoTo NX

i = i + 1

ReDim Preserve MyAry(1 To 6, 1 To i)

MyAry(1, i) = ii

MyAry(2, i) = sFind.Cells(ii, "A").Value

MyAry(3, i) = sFind.Cells(ii, "B").Value

MyAry(4, i) = sFind.Cells(ii, "C").Value

MyAry(5, i) = sFind.Cells(ii, "E").Value

MyAry(6, i) = sFind.Cells(ii, "F").Value

NX:

Set Cel = .FindNext(Cel)

Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress

End If

End With


'====================================

If i Then

MySve = MyTextFind

With sPast

.Range("A2").Resize(2, 6).Copy

.Range("A2").Resize(i, 6).PasteSpecial xlPasteFormats

Application.CutCopyMode = False

.Range("A2").Select

.Range("A2").Resize(i, 6).Value = WorksheetFunction.Transpose(MyAry)

End With

End If

'====================================

1:

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


If Err Then

MsgBox "Err.Number : " & Err.Number: Err.Clear

Else

MsgBox IIf(i, "عدد نتائج البحث : " & i, "لا توجد نتائج للبحث "), 524288 + 1048576, "النتيجة"

End If

2:

Erase MyAry

Set sFind = Nothing

Set sPast = Nothing

Set Cel = Nothing

End Sub

تم تغيير المرفق بعد وصول عدد التحميل 7

من حمل سابقا فليحمل المرفق الجديد

2003 2007

كود بحث 1.rar

[أبو حنــــين]

السلام عليكم

بكل صدق هذا من أروع ما رأيت

بارك الله فيكم أخي عبد الله باقشير

[رجب جاويش]

أستاذى الحبيب / عبد الله باقشير

كود رائع وعبقرى كما هو متوقع دائما من عالمنا الجليل / عبد الله باقشير

وأسمح لى أستاذى باستفسار صغير فى الجزئية الخاصة بالرسالة التالية

MsgBox IIf(i, "عدد نتائج البحث : " & i, "لا توجد نتائج للبحث "), 524288 + 1048576, "النتيجة"

أرجو توضيح هذه الجزئية الخاصة بالـ msgbox والتى تحتوى على رسالتين

اذا كان المتغير i له قيمة تظهر الرسالة الأولى التى تحدد عدد نتائج البحث

واذا كان المتغير i ليست له قيمة تظهر الرسالة الثانية التى توضح أنه لا توجد نتائج للبحث

فأنا أريد شرح كيفية التنفيذ

وخاصة الجزء iif الموجود قبل قوس الرسالة والأرقام 524288 + 1048576

وكل عام وأنتم بألف خير وسعادة

[عبدالله المجرب]

السلام عليكم

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

===

كما هو معروف فدالة Msgbox

تعتمد على عدة متغيرات

1. نص الرسالة وهنا الاستاذ عبدالله استخدم دالة IIF الشرطية

ودالة تتكون من ثلاثة متغيرات

أ. الشرط وهنا هو قيمة المتغيير i

ب. النتيجة في حالة True

ج. النتيجة في حالة False

==

2. الازرار

وهنا في الوضع الافتراضي سيكون الزر هو زر OK لذا الاستاذ عبدالله لم يحدد أزرار

والارقام هنا (524288 + 1048576) تعني:

1. 524288 هذا لمحاذاة نص الرسالة يمين

2. 1048576 لمحاذاة عنوان الرسالة يمين

3. عنوان الرسالة

والله اعلم

====

[أبو ردينة]

ما شاء الله لا قوة إلا بالله

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

|

[أبو ردينة]

بارك الله فيك أخي الحبيب / أبو أحمد

يبدو أني نشرت في نفس الوقت فأرجو منك المعذرة

[عبدالله المجرب]

العفو

وان شاء الله تكون المعلومة صحيحة

[رجب جاويش]

أخى الحبيب / عبد الله المجرب

بالنسبة للدالة الشرطية ( if ) لماذا كتبت بحرفين ii هكذا ( iiF )

[رجب جاويش]

أخى الحبيب / عبد الله المجرب

تقبل أرق وأجمل تحياتى

هذا المنتدى يجعلنى أتعلم الجديد والجديد كل يوم

فأنا لم أكن أعلم قبل ذلك عن وجود دالة iif فى vba

وبعد البحث وجدت كل المعلومات الخاصة بها

واسمحلى أن أشيد بشرحك الصحيح تماما

فدالة iif تعتبر بديل عن جملة If...Then...Else

وشكل الدالة يكون كالآتى

IIf(Expression As Boolean,TruePart As Object,FalsePart As Object) As Object

1- الشرط 2- النتيجة فى حالة true 3- النتيجة فى حالة false مثال : عند استخدام if العادية

If 10 > 9 Then

MsgBox("True")

Else

MsgBox("False")

End If

أما عند استخدام iif يكون تركيبها كالاتى

MsgBox(IIf(10 > 9, "True", "False"))

أجمل وأرق تحية لكل من

الأستاذ / عبد الله المجرب

العالم الكبير / عبد الله باقشير

اللذين نتعلم منهم الجديد والمفيد كل يوم وكل مشاركة لهم

وكل عام وأنتم بخير

[جمال جبريل]

فقط لي طلب .... كيف يمكنني تغيير مثلا ( العمود الذي يبحث فيه ، الورقة التي تبحث فيها ، البيانات الذي اريد ان استخرجها مثلا اضافة عمود جديد مثل عدد النسخ ، بداية الكتابة مثلا من البداية الصف الثاني والعمود الثاني ، اي يبدا ( A2:F2).

[عبدالله باقشير]

السلام عليكم

بكل صدق هذا من أروع ما رأيت

بارك الله فيكم أخي عبد الله باقشير

اكرمك الله اخي ابو حنين

وجزاك خيرا وبارك فيك

تقبل تحياتي وشكري

[عبدالله باقشير]

السلام عليكم

الاخ الحبيب / رجب جاويش ------------حفظه الله

الاخ الحبيب / عبدالله المجرب ------------حفظه الله

نقاش رائع

امتياز في الاسلوب والسؤال والجواب

ولا ننسى الخلق الحسن

ساضيف معلومة عن iif

ان بامكانك اختبار الشرط بها في سطر تنفيذ التعليمات

MsgBox IIf(r, "عدد نتائج البحث : " & r, "لا توجد نتائج للبحث "), 524288 + 1048576, "النتيجة"

جعلني افكر في استخدام

هذا النهج كاسلوب تعليمي بمساعدتكما

في المرات القادمة

ان شاء الله

جزاكم الله خيرا وبارك فيكم

تقبلوا تحياتي وشكري

[عبدالله باقشير]

السلام عليكم

الاخ الحبيب / ابو ردينة ----------------حفظك الله

وجزاك خيرا وبارك فيك

تقبل تحياتي وشكري

[عبدالله باقشير]

السلام عليكم

في المرفق 2003

توضيح عن الارقام المستخدمة مع

MSGBOX

MSGBOX.rar

[رجب جاويش]

أستاذى الحبيب / عبد الله باقشير

نحن تلاميذ فى جامعتك العريقة

نتشوق لابداعاتك لنتعلم منها

أى نهج وأى أسلوب تعليمى يراه الأستاذ سوف يجد طلابه يقولون سمعا وطاعة

[عبدالله باقشير]

أستاذى الحبيب / عبد الله باقشير

نحن تلاميذ فى جامعتك العريقة

نتشوق لابداعاتك لنتعلم منها

أى نهج وأى أسلوب تعليمى يراه الأستاذ سوف يجد طلابه يقولون سمعا وطاعة

حفظك ربي واكرمك وازال همك

وجزاك خيرا وبارك فيك

تقبل ازكى تحياتي

وباقات شكري وتقديري

[عبدالله باقشير]

فقط لي طلب .... كيف يمكنني تغيير مثلا ( العمود الذي يبحث فيه ، الورقة التي تبحث فيها ، البيانات الذي اريد ان استخرجها مثلا اضافة عمود جديد مثل عدد النسخ ، بداية الكتابة مثلا من البداية الصف الثاني والعمود الثاني ، اي يبدا ( A2:F2).

العمود الذي يبحث فيه

السطر

With sFind.Range("C1:C65000")

الورقة التي تبحث فيها

​Set sFind = Worksheets("البحث في المكتبة")

البيانات الذي اريد ان استخرجها الاسطر

MyAry(1, i) = ii

            MyAry(2, i) = sFind.Cells(ii, "A").Value

            MyAry(3, i) = sFind.Cells(ii, "B").Value

            MyAry(4, i) = sFind.Cells(ii, "C").Value

            MyAry(5, i) = sFind.Cells(ii, "E").Value

            MyAry(6, i) = sFind.Cells(ii, "F").Value

اول سطر خاص برقم الصف الذي نستخدمة للارتباط

MyAry(1, i) = ii

اما البقية فهي الخلايا المطلوبة تعيين عدد الاعمدة هنا

ReDim Preserve MyAry(1 To 6, 1 To i)

الرقم 6 الاول لرقم الصف ما لويش دخل بالخلايا البقية وهي خمسة للخلايا عند الزيادة او النقصان تغير الرقم 6 مثلا عند زيادة خلية اخرى تغير الرقم 6 الى 7 وتضيف سطر آخر للعمود المطلوب مثلا

 MyAry(7, i) = sFind.Cells(ii, "G").Value

بداية الكتابة مثلا من البداية الصف الثاني والعمود الثاني هذا السطر مثلا معناه بداية من A2 بمقاس 2 صف و6 اعمدة

.Range("A2").Resize(2, 6)

[جمال جبريل]

بعد محاولات ، تم اخذ البيانات المطلوبة ، ولكن عند الضغط دبل كليك يذهب الي بيانات اخرى ، اريد اولا ان يبدا من العمود الثاني والصف الثالث ، وان يكون الانتقال في الخلية الاولى (الرقم الخاص) بارتباط تشعبي بدلا من دبل كليك، وبالاضافة الي ذلك بعد اضافة كود يلون الصف المختار جعل الملف مرتعش كانه اخذه برد من كثر تكثيف الذاكرة على ما اظن ، فمال الحل..

كود بحث في عدة اوراق.rar

[عبدالله باقشير]

بعد محاولات ، تم اخذ البيانات المطلوبة ، ولكن عند الضغط دبل كليك يذهب الي بيانات اخرى ، اريد اولا ان يبدا من العمود الثاني والصف الثالث ، وان يكون الانتقال في الخلية الاولى (الرقم الخاص) بارتباط تشعبي بدلا من دبل كليك، وبالاضافة الي ذلك بعد اضافة كود يلون الصف المختار جعل الملف مرتعش كانه اخذه برد من كثر تكثيف الذاكرة على ما اظن ، فمال الحل..

وعليكم السلام

انت لخبطت الكود وكنسلت خلية الارتباط

عموما هذا طلبك

وبلاش الالوان والحاجات اللي تثقل الملف

علشان يعمل معاك تمام

Option Explicit

'=============================================

' اسم ورقة وضع نتائج البحث

Const sNamePast As String = "نتائج البحث"

' اسم ورقة البحث

Const sNameFind As String = "البحث في المكتبة"

'=============================================

Sub Kh_Find()

Static MySve As String

Dim MyTextFind As Variant

Dim FirstAddress As String

Dim sFind As Worksheet

Dim RngPast As Range

Dim RngFind As Range

Dim cel As Range

Dim i As Long

Dim ii As Long


On Error GoTo 1

'====================================

' الصف الاول من خلايا وضع النتائج

Set RngPast = Worksheets(sNamePast).Range("B3:G3")

'====================================


With RngPast

.Worksheet.Activate

.Range("A1").Activate

.Offset(1, 0).Resize(.Worksheet.UsedRange.Rows.Count).EntireRow.Delete

.ClearContents

End With


MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث", MySve, 100, 100, , , 2)

If MyTextFind = "" Or MyTextFind = False Then GoTo 1


'====================================

Set sFind = Worksheets(sNameFind)

Set RngFind = sFind.Columns(3).Cells

'====================================


'====================================

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'====================================

Set cel = RngFind.Find(MyTextFind, LookIn:=xlValues)

If Not cel Is Nothing Then

FirstAddress = cel.Address

Do

ii = cel.Row

If ii = 1 Then GoTo NX

i = i + 1

With RngPast

.Cells(i, 1) = sFind.Cells(ii, "A").Value

.Cells(i, 2) = sFind.Cells(ii, "B").Value

.Cells(i, 3) = sFind.Cells(ii, "C").Value

.Cells(i, 4) = sFind.Cells(ii, "E").Value

.Cells(i, 5) = sFind.Cells(ii, "F").Value

.Cells(i, 6) = sFind.Cells(ii, "H").Value


kh_AddHlink .Cells(i, 1), ii

End With

NX:

Set cel = RngFind.FindNext(cel)

Loop While Not cel Is Nothing And cel.Address <> FirstAddress

End If


'====================================

If i Then

MySve = MyTextFind

With RngPast

.AutoFill .Resize(i), xlFillFormats

End With

End If

'====================================

1:

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


If Err Then

MsgBox "Err.Number : " & Err.Number: Err.Clear

End If


Set sFind = Nothing

Set RngPast = Nothing

Set RngFind = Nothing

Set cel = Nothing

End Sub

' اضافة ارتباط تشعيبي

Sub kh_AddHlink(HRng As Range, iR As Long)

Dim sAdr As String

sAdr = "'" & sNameFind & "'!" & Range("A" & iR).Address

HRng.Worksheet.Hyperlinks.Add HRng, "", sAdr, sAdr

End Sub

كود بحث في عدة اوراق.rar

[جمال جبريل]

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

[أبو ردينة]

الإخوة الأحبة في الله

أستاذنا / عبد الله باقشير

أستاذنا / عبد الله المجرب

أستاذنا / رجب جاويش

و باقي الإخوة الكرام جميعا

زادكم الله من فضله و رزقكم من العلم أنفعه و من الخير أوسعه عاجلا غير آجل و من حيث لا تحتسبوا

[جمال جبريل]

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

[غسان العبيدي]

جزاكم الله خيرا ... يا طيبين ... فتح الله عليكم من بركاته .. ورزقكم الجنة بلا حساب

[خالد القدس]

السلام عليكم ورحمة الله

أستاذي الكريم خبور

حقيقة بعد أن راودني الاحباط واليأس من فهم أكواد أعمالك المميزة

ها هو بريق الأمل يراودني من جديد

شرح وافي يسمع الأصم ويري الأعمى ويهدي الحيارى

بارك الله فيك وزادك رفعة وعلوا