استخدام اوسع للدالة VLOOKUP

**هشام شلبى** · يوليو 18, 2011

السلام عليكم

=====

اليوم ساقدم لكم استخدام مبهر للدالة VLOOKUP

تعودنا ان الدالة VLOOKUP تبحث عن قيمة معينة فى نطاق محدد " فى صفحة محددة"

اليوم ستقوم الدالة VLOOKUP بالبحث عن قيمة محددة فى عدة نطاقات وفى عدة صفحات

الدالة اسمها multvlookup وهى من النوع U D F

Option Explicit[/b]


[b]Public Function MultVlookup( _[/b]

[b]            FindThis As Variant, _[/b]

[b]            LookIn As Range, _[/b]

[b]            SheetRange As String, _[/b]

[b]            OffsetColumn As Integer) _[/b]

[b]        As Variant[/b]


[b]Dim Sheet As Worksheet[/b]

[b]Dim strFirstSheet As String[/b]

[b]Dim strLastSheet As String[/b]

[b]Dim SheetArray() As String[/b]

[b]Dim blnFirstSheet As Boolean[/b]

[b]Dim rngFind As Range[/b]

[b]Dim blnFound As Boolean[/b]

[b]Dim n As Integer[/b]


[b]'جعل نطاق البحث عمود واحد[/b]

[b]If LookIn.Columns.Count > 1 Then[/b]

[b]    Set LookIn = LookIn.Resize(LookIn.Rows.Count, 1)[/b]

[b]End If[/b]


[b]'حجم الصفيف لاحتواء كافة أسماء ورقة عمل[/b]

[b]ReDim SheetArray(ActiveWorkbook.Worksheets.Count)[/b]


[b]'الحصول على أسماء ورقة العمل[/b]

[b]strFirstSheet = Left(SheetRange, InStr(1, SheetRange, ":") - 1)[/b]

[b]strLastSheet = Right(SheetRange, _[/b]

[b]                Len(SheetRange) - InStr(1, SheetRange, ":"))[/b]

[b]'وضع أسماء ورقة عمل في "نطاق ورقة" مجموعة في صفيف[/b]

[b]blnFirstSheet = False[/b]

[b]n = 0[/b]

[b]For Each Sheet In ActiveWorkbook.Worksheets()[/b]

[b]    If Sheet.Name = strFirstSheet Then[/b]

[b]        blnFirstSheet = True[/b]

[b]    End If[/b]

[b]    If blnFirstSheet = True Then[/b]

[b]        SheetArray(n) = Sheet.Name[/b]

[b]        n = n + 1[/b]

[b]    End If[/b]

[b]    If Sheet.Name = strLastSheet Then[/b]

[b]        blnFirstSheet = False[/b]

[b]    End If[/b]

[b]Next Sheet[/b]


[b]'نطاق البحث في كل ورقة عمل في مجموعة[/b]

[b]blnFound = False[/b]

[b]For n = 0 To UBound(SheetArray, 1)[/b]

[b]    With Worksheets(SheetArray(n)).Range(LookIn.Address)[/b]

[b]        Set rngFind = .Find(FindThis, LookIn:=xlValues, _[/b]

[b]                        MatchCase:=False, LookAt:=xlWhole)[/b]

[b]    End With[/b]

[b]    If Not rngFind Is Nothing Then[/b]

[b]        'ايجاد النتيجة[/b]

[b]        blnFound = True[/b]

[b]    End If[/b]

[b]    If blnFound = True Then Exit For[/b]

[b]Next n[/b]


[b]'عودة القيمة[/b]

[b]If blnFound = True Then[/b]

[b]    MultVlookup = rngFind.Offset(0, OffsetColumn - 1)[/b]

[b]    Else[/b]

[b]    MultVlookup = "Not Found"[/b]

[b]End If[/b]

[b]End Function[/b]

[b]

وسوف لا اتكلم كثيرا فالدالة تتحدث عن نفسها

المساعدة.rar

**عبدالله باقشير** · يوليو 18, 2011

========================

الاخ الحبيب/ هشام شلبي

========================

و

**عبد الفتاح كيرة** · يوليو 18, 2011

الشكر الجزيل أستاذ هشام

على الهدية القيمة

**عبدالله المجرب** · يوليو 19, 2011

ما شاء الله

ابداع جديد يضاف الى رصيد المنتدى من الدوال المعرفه

سلمت يمينك استاذ هشام

بوعلام · يوليو 19, 2011

ما شاء الله

ابداع جديد يضاف الى رصيد المنتدى من الدوال المعرفه

سلمت يمينك استاذ هشام

ابداع ما بعده إبداع أستاذي

**مصطفى كمال** · يوليو 19, 2011

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

أخي الكريم هشام ، شكرا جزيلا على الدالة وعمل رائع، بارك الله فيك

**ياسر الحافظ** · يوليو 19, 2011

استاذنا الكبير هشــــــــــــــــــــام :

لم اجربه بعد ... ولكن واضح انها رائعة مثل كل اعمالك

وفقك الله

ياسر الحافظ " ابو الحارث "

عماد محى الدين · يوليو 19, 2011

بجد استاذ و رئيس قسم

ربنا يكرمك اكثر من رائع

**الـعيدروس** · يوليو 19, 2011

بارك الله فيك استاذ هشام

عمل رائع

وفقك الله

**الحسامي** · يوليو 19, 2011

السلام عليكم

اخي الحبيب هشام شلبي

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

-------------------------------------

ولكن للفائدة

هذه الدالة يوجد بها عيب وهو عدم تحديث البيانات عند تغييرها اي عندما

نقوم بتغيير البيانات الرئيسية فلا تقوم هذه الدالة بايجاد البيانات

الجديدة لعدم وجود الية لتحديث البيانات في داخل الكود وهذه الدالة بالاساس

كانت المسودة الاولى والتجريبية لهذه الدالة

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

الموجودة فيها حيث قام باستخدام امر تحديث البيانات لتحديث البيانات تلقائياً باستخدام الامر

Application.Volatile

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

=multvlookup(A2,$A$2:$B$1000,"MyS1:MyS5",2,FALSE)


Public Function MultVlookup( _

                    FindThis As Variant, _

                    LookIn As Range, _

                    SheetRange As String, _

                    OffsetColumn As Integer, _

                    Optional ReturnAddress As Boolean = False) _

                As Variant

Dim Sheet As Worksheet

Dim strFirstSheet As String

Dim strLastSheet As String

Dim SheetArray() As String

Dim blnFirstSheet As Boolean

Dim rngFind As Range

Dim blnFound As Boolean

Dim intSheets As Integer

Dim n As Integer


Application.Volatile


If LookIn.Columns.Count > 1 Then

    Set LookIn = LookIn.Resize(LookIn.Rows.Count, 1)

End If


ReDim SheetArray(ActiveWorkbook.Worksheets.Count)


strFirstSheet = Left(SheetRange, InStr(1, SheetRange, ":") - 1)

strLastSheet = Right(SheetRange, _

                Len(SheetRange) - InStr(1, SheetRange, ":"))

blnFirstSheet = False

n = 0

For Each Sheet In ActiveWorkbook.Worksheets()

    If Sheet.Name = strFirstSheet Then

        blnFirstSheet = True

    End If

    If blnFirstSheet = True Then

        SheetArray(n) = Sheet.Name

        n = n + 1

    End If

    If Sheet.Name = strLastSheet Then

        blnFirstSheet = False

    End If

Next Sheet

intSheets = n


blnFound = False

For n = 0 To intSheets - 1

    With Worksheets(SheetArray(n)).Range(LookIn.Address)

        Set rngFind = .Find(FindThis, LookIn:=xlValues, _

                        MatchCase:=False, LookAt:=xlWhole)

    End With

    If Not rngFind Is Nothing Then

        blnFound = True

    End If

    If blnFound = True Then Exit For

Next n


If blnFound = True Then

    If ReturnAddress = False Then

        MultVlookup = rngFind.Offset(0, OffsetColumn - 1)

        Else

        MultVlookup = SheetArray(n) & "!" & _

            rngFind.Offset(0, OffsetColumn - 1).Address

    End If

    Else

    MultVlookup = CVErr(xlErrNA)

End If

End Function

المساعدة.rar

تم تعديل يوليو 19, 2011 بواسطه الحسامي

**ياسر الحافظ** · يوليو 19, 2011

الاخوة الاساتذة : هشـــــــــــــــــــــــــــام - الحســــــــــــــــــــــــــــــامي :

بداية كل الشكر لهذه الرائعة المميزة

ولي استفسار ( رجاء ) طلبي موضح في الملف المرفق

وفقكم الله

ياسر الحافظ " ابو الحارث "

استخدام اوسع للدالة VLOOKUP - هشام - الحسامي.rar

**ياسر الحافظ** · يوليو 20, 2011

up

**الحسامي** · يوليو 20, 2011

السلام عليكم

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

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

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

Option Explicit

Public Function MultVlookup( _

                    FindThis As Variant, _

                    LookIn As Range, _

                    SheetRange As String, _

                    OffsetColumn As Integer, _

                    Optional ReturnAddress As Boolean = False) _

                As Variant

Dim Sheet As Worksheet

Dim strFirstSheet As String

Dim strLastSheet As String

Dim SheetArray() As String

Dim blnFirstSheet As Boolean

Dim rngFind As Range

Dim blnFound As Boolean

Dim intSheets As Integer

Dim rngFind1 As String

Dim n As Integer

Dim Total_sum As Integer

Dim sum As Integer


Application.Volatile


If LookIn.Columns.Count > 1 Then

    Set LookIn = LookIn.Resize(LookIn.Rows.Count, 1)

End If


ReDim SheetArray(ActiveWorkbook.Worksheets.Count)


strFirstSheet = Left(SheetRange, InStr(1, SheetRange, ":") - 1)

strLastSheet = Right(SheetRange, Len(SheetRange) - InStr(1, SheetRange, ":"))

blnFirstSheet = False

n = 0

For Each Sheet In ActiveWorkbook.Worksheets()

    If Sheet.Name = strFirstSheet Then

        blnFirstSheet = True

    End If

    If blnFirstSheet = True Then

        SheetArray(n) = Sheet.Name

        n = n + 1

    End If

    If Sheet.Name = strLastSheet Then

        blnFirstSheet = False

    End If

Next Sheet

intSheets = n


blnFound = False

For n = 0 To intSheets - 1

 Set rngFind = Worksheets(SheetArray(n)).Range(LookIn.Address).Find(FindThis, LookIn:=xlValues, _

  MatchCase:=False, LookAt:=xlWhole)

       If Not rngFind Is Nothing Then

       blnFound = True

       Else

       blnFound = False

       End If


   If blnFound = True Then

   sum = rngFind.Offset(0, OffsetColumn - 1)

   Else

   sum = 0

   End If

Total_sum = sum + Total_sum

Next n

MultVlookup = Total_sum

End Function

استخدام اوسع للدالة VLOOKUP - هشام - الحسامي1.rar

**ياسر الحافظ** · يوليو 20, 2011

استاذنا الحســـــــــــــــــــــــــــــــامي :

تماما ... هذا هو طلبي

جزاك الله كل الخير ... استاذ الاساتذة

وفقك الله

ياسر الحافظ " ابو الحارث "

**يوسف عطا** · يوليو 20, 2011

هشام بك

الحسامى بك

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

تفبلا مودتى

**محمد يحياوي** · يوليو 20, 2011

الاستاذ هشام شلبي نشكرك جزيل الشكر على المجهودات الجبارة و الاعمال الرائعة

الحقيقة الدالة بعد التعديل اصبحت جبارة فكل الشكر و الامتنان

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

وفقكم الله جميعا الى الخير

عماد محى الدين · يوليو 21, 2011

الف شكر للاخ الحسامى

تسلم الايدى يا جميل

**KHMB** · يوليو 21, 2011

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

الأستاذ / هشام شلبي

الأستاذ / الحســامي

2IN 1

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

تم تعديل يوليو 21, 2011 بواسطه KHMB

**هشام شلبى** · يوليو 21, 2011

السلام عليكم

=====

اخى الحبيب خبور خير *** بارك الله فيك

اخى KHMB *** بارك الله فيك

اخى عماد محى الدين *** بارك الله فيك

اخى yahiaoui *** بارك الله فيك

اخى يوسف عطا *** بارك الله فيك

اخى مصطفى كمال *** بارك الله فيك

اخى بو علام *** بارك الله فيك

اخى alidroos *** بارك الله فيك

اخى الحبيب الحسامى *** بارك الله فيك وزادك من العلم اضعافا مضاعفة

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

والتمسوا لى العذر فى فترة غيابى القادمة . الى حين الانتهاء من الامتحانات فى اخر الاسبوع القادم

اترككم فى رعاية الله

**الـعيدروس** · يوليو 21, 2011

السلام عليكم

الاساتذه الافاضل

هشام شلبي

عماد الحسامي

تميز وانفراد

وفقكم الله

الزير · يوليو 21, 2011

الاستاذ هشام شلبي

دالة روعة واعتقد ان هناك داله شبيهة لها من ابداع الاستاذ ابوتامر واسمها VLOOKON

وكان الله في عونك وان يمدك بالقوة والصبر والعافية

ابووائل

**ياسر الحافظ** · يوليو 21, 2011

الاخ الزيـــــــــــــــــــــــر :

نرجوا ان كان ممكنا ان ترفع لنا ملف ( مثال ) عن الدالة : VLOOKON

وشكرا

ابو الحارث

الزير · يوليو 22, 2011

الاخ الزيـــــــــــــــــــــــر :

نرجوا ان كان ممكنا ان ترفع لنا ملف ( مثال ) عن الدالة : VLOOKON

وشكرا

ابو الحارث

ابو الحارث

خذ المرفق وقارن

وهذا رابط الموضوع

http://www.officena.net/ib/index.php?showtopic=15350

VLOOKON_With_No_Limitation.rar

تسجيل الدخول

استخدام اوسع للدالة VLOOKUP

الردود الموصى بها

هشام شلبى

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

عبد الفتاح كيرة

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

بوعلام

مصطفى كمال

ياسر الحافظ

عماد محى الدين

الـعيدروس

الحسامي

ياسر الحافظ

ياسر الحافظ

الحسامي

ياسر الحافظ

يوسف عطا

محمد يحياوي

عماد محى الدين

KHMB

هشام شلبى

الـعيدروس

الزير

ياسر الحافظ

الزير

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information