اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

إستخلاص أسماء صور من فهرس


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

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

أساتذتي الأفاضل حفظكم الله

خواتم مباركة وتقبل الله منا ومنكم صالح الأعمال

المطلوب كود في حدث الـ workbook

يقوم بالعمل آلياً والتحديث المستمر بمجرد فتح الملف في أستخلاص أسماء الصور من الفهرس (الفولدر) المسمى MyImage ووضعها في العمود Z أبتداءاً من الخلية Z2 مع الأخذ بعين الأعتبار أن عدد الصور سيكون كثير جداً حتى يكون الكود مرن من هذه الناحية

ولكم جزيل الشكر والاحترام

أبو أنس ناصر حاجب

قاعدة بيانات صور.rar

رابط هذا التعليق
شارك

السلام عليكم

أخي الغالي / أبا أنس

جرب هذا الكود في حدث الملف



Private Sub Workbook_Open()

pth = ActiveWorkbook.Path & "\MyImage\"

Range("Z2:Z" & [Z60000].End(xlUp).Row).ClearContents

x = Dir(pth)

    Do While x <> ""

        i = i + 1

        Sheets(1).[Z1].Offset(i, 0).Value = Left(x, Len(x) - 4)

        x = Dir()

    Loop

End Sub


رابط هذا التعليق
شارك

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

جزاك الله كل خير على سرعة الرد

أرجو التأكد من السطر الأول فهو يشير لدي عند نسخة إلى وجود خطأ فيه.

أبو أنس

رابط هذا التعليق
شارك

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

بارك الله لك وبك وفيك

كل شئ تمام الآن

بلغك الله ليلة قدره

أبو أنس

رابط هذا التعليق
شارك

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

أستميحك عذراً في العودة لهذا الموضوع لأمرين:

الاول عبارة عن تساؤل .. هل أذا اردت ان يعمل الملف لدي في بيئة الأوفيس 2007 أن أحفظ الملف بهذه الصيغة Excel 2007 Macro-Enabled Workbook حيث أنني نقلت الملف إلى جهاز لاب تب فيه الويندوز 7 ولم يعمل الكود.

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

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

أبو أنس

رابط هذا التعليق
شارك

السلام عليكم

الاول: تساؤل .. هل أذا اردت ان يعمل الملف لدي في بيئة الأوفيس 2007 أن أحفظ الملف بهذه الصيغة Excel 2007 Macro-Enabled Workbook

نعم ، كل ماعليك ان تحفظه بتلك الصيغة ذات الإمتداد xlsm

الثاني لاحظت أن الكود يقوم بداية بمسح جميع البيانات في العمود المذكور ثم يقوم بجلب أسماء الصور

هل جلب البيانات يعتمد على التسلسل في الموقع أو الأسم أو تاريخ أضافته إلى الفهرس

جلب البيانات يعتمد على الملفات الموجودة بالفعل في الموقع

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

تفضل المرفق وبه ماطلبت

قاعدة بيانات صور.rar

رابط هذا التعليق
شارك

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

أستاذي وسيدي الفاضل طارق محمود حفظك الله

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

ارفق لك الملف الأصلي كي تتضح الرؤية للمطلوب.

ارجو أن تفتح ملف الاكسيل قبلاً ثم تلاحظ الملاحظات التي توجد مقابل أسم أنس ثم أقفل الملف واحفظه

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

أرجو أن تكون وضحت الصورة

جزاك الله من الخير حتى ترضى وأكرم منزلك في الدارين.

أبو أنس

قاعدة بيانات للصور.rar

رابط هذا التعليق
شارك

السلام عليكم

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

بعد اذن اخي الحبيب طارق حفظه الله

ائراءا للموضوع

عندي كود في احد ملفاتي يقوم بمثل هذا الطلب

مع تغيير بسيط في الكود


Option Explicit

'//////////////////////////////////////////////////////


Sub kh_AddNamePicture()

Dim MyObj, MyObjFol, Obj

Dim MySheet As Worksheet

Dim iPath As String, iName As String

Dim Last As Long, i As Long

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

On Error GoTo Err_kh_Files

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

iPath = ActiveWorkbook.Path & "\MyImage\"

Set MyObj = CreateObject("Scripting.FileSystemObject")

Set MyObjFol = MyObj.GetFolder(iPath)

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

Set MySheet = ThisWorkbook.Worksheets("Sheet1")

Last = MySheet.Cells(Rows.Count, "Z").End(xlUp).Row

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

For Each Obj In MyObjFol.Files

    If Not Dir(Obj.Path, vbDirectory) = "" Then

        iName = Left(Obj.Name, InStrRev(Obj.Name, ".") - 1)

        With MySheet

            If WorksheetFunction.CountIf(.Range("Z2").Resize(Last), iName) = 0 Then

                i = i + 1

                .Cells(Last + i, "Z").Value = iName

            End If

        End With

    End If

Next

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

Err_kh_Files:

If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear

Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing

End Sub

لعلكم تجدون فيه ضالتكم

ولتعم الفائدة

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

رابط هذا التعليق
شارك

السلام عليكم

أخي / أبا أنس

إذا حضر الماء ، بطل التيمم

أخي الحبيب وأستاذي /عبدالله

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

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

اسال الله أن يتقبّل صيامنا وقيامنا وأن يعيد الشهر الكريم علينا اجمعين

رابط هذا التعليق
شارك

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

أستاذي وسيدي ومفخرتي من بني قومي وتاج رأسي عبد الله باقشير حفظك الله ورفع قدرك في الفردوس الأعلى

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

كل عام وأنتم في خير ونعمة وعافية ولاحرمكم الله من نعيم الدنيا والآخرة

جزاك الله كل الخير حتى ترضى ورضي ربي عنك ومتعك بالنظر إلى وجهه الكريم وحفظ لك ذر يتك من بعدك وإلحقهم بك بعد عمر مديد ورزق وفير وعلم يستقاد به جزيل.

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

الدعاء موصول لأستاذي وسيدي وحبيبي في الله طارق محمود حفظه الله

أبو أنس ناصر حاجب

تم تعديل بواسطه أبو أنس حاجب
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information