ابو تراب

بعد اذن مشرفنا الفاضل جمال عبد السميع ...هذه محاولة للاجابة عن سؤال اخينا ابو نبا اخي ابو نبأ انظر للمرفق .. (تركت لك شيت البطاقة لتجرب عليها بنفسك) ملاحظة: ====== 1 - افترضت ان كل صورة موجودة على ال D في مجلد صور 2 - افترضت ان ابعاد الصورة هيى 176 في 126 بكسل 3 - الصورة ذات امتداد jpg 4 - عرض عمود الصورة هو 26 و ارتفاع سطرها 100 لتجريب ===== انسخ مجلد الصور من المرفق الى ال D بيانات.zip

هلا ابوتيم جرب الملف المرفق... ملاحظة -------- 1 - اضفت عمود تاريخ انتهاء الضمان لتسهيل عملية الحساب 2- مدة الضمان ستعتمد على السنين و الاشهر و ليس الايام...مثلا سنتين و ثلاثة اشهر ستكتب 2.25 3- اضفت تاريخ اليوم على حسب طلبك...معادلة تاريخ اليوم هى: DATE(YEAR(NOW()),MONTH(NOW()),DAY(NOW())) 1.zip

جرب الان حساب المدة الفعلية.zip

وعليكم السلام و رحمة الله و بركاته شيك على المرفق ... فضلا تأكد اذا كانت المدة على حسب ماتتوقعه. افترضت الشهر 30 يوما و السنة 360 يوم. حساب المدة الفعلية.zip

وعليكم السلام و رحمة الله شيك على المرفق Add years to a date.zip

صبحك الله بالنور و السرور ارى لتسهيل الامر ان تنسخ الشيت من الملف الثاني الى الملف الاول و بعدها تطبق الدالة VLookup ...الطريقة انك ستعتمد على عمود اللغة الغة الانجليزية لبرط الجدولين: IFERROR(VLOOKUP(A1,AR!$A$1:$B$50,2,FALSE),"") 1 - الخلية A1 تمثل الكلمة الانجليزية في جدول اللغة الفرنسية المراد البحث عنها في جدول اللغة العربية 2- AR!$A$1:$B$50 تمثل حدود جدول اللغة العربية في الشيت AR 3- يمثل العمود الثاني من جدول اللغة العربية وهو عمود المعنى بالعربي 4- FALSE معناه يجب تطابق الكلمة الانجليزية في الجدول اللغة الفرنسية مع نظيرتها في جدول اللغة العربية لمزيد من المعلومات يمكنك مراجعة الموضوع التالي للاخ الفاضل حسام http://www.officena.net/ib/index.php?showtopic=57036&hl=vlookup

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

وعليكم السلام ورحمة الله جرب المرفق All.zip

الاخ الفاضل مختار ... مشكور على الكود الاكثر من رائع اذا واجهت احدكم مشكلة في تنفيد الكود يمكنك حلها بتفعيل الخيار: Trust access to the VBA project object model

هلا ابو يحيى هل تقصد الدالة ISBLANK يمكنك الاستعاضة عنها عن طريق فحص القيمة نفسها. مثلا: بدلا من: ISBLANK($B$2:$B$250) جرب $B$2:$B$250=""

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

هلا تامر هذا كود خفيف و بدون تعقيدات لفحص اذا الملف موجود: Function checkIfFileExists(FileName As String) As Boolean checkIfFileExists = (Dir(FileName) > "") End Function Sub btnCheckFile() If checkIfFileExists([B1]) Then MsgBox "الملف موجود", vbInformation + vbOKOnly Else MsgBox "الملف غير موجود", vbCritical + vbOKOnly End If End Sub ملاحظة ===== اذا اردت التحقق من وجود ملف فادخل المسار كاملا. مثلا: C:\test\myFile.txt اما اذا اردت التاكد من مجلد معين فيجب اضافة \ لنهاية المسار. مثلا C:\test\ Check If File Exists.zip

وعليكم السلام ورحمة الله وبركاته هلا بيك Zika86 عندي بعض الاقتراحات من الاسهل الى الاصعب: 1- في الصورة 2 ابحث اذا كان يوجد خيار Extract to Excel 2- ابحث اذا كان هناك خيار Extract to CSV ... تستطيع استيراده الى الاكسل و العمل عليه. 3- اطلب من قسم ال IT ان يتم اضافة هذه الميزة (Extract to Excel) او ان يتم تصميم تقرير جديد...هذا يعتمد اذا كان تم تطوير هذا البرنامج من فريق الشركة او خارجها. 4- اما اذا كان لابد من استخراج البيانات من قاعدة البيانات...هنا انصح باستخدام برنامج الاكسس.. و ليس الاكسل(تستطيع بالاكسل عن طريق كود {VBA) ... الصعوبة ==== تحتاج لانشاء اتصال بقاعدة البيانات و هنا ستستخد عنوان ال IP و البورت 7777 و اسم المستخدم و كلمة المرور و اسم قاعدة البيانات. ستحتاج لربط LINK الاكسل بالقاعدة بعد نجاح الاتصال ستحتاج لمعرفة العلاقات بين الجداول لانشاء الاستعلام وبعدها يمكنك نسخ نتائج الاستعلام و لصقها بالاكسل. هذه صورة مبسطة و خطوط عريضة للحل الرابع.

مبروووووووووك والف مبروك تستاهل كل خير ومن تقدم إلي تقدم إن شاء الله نتمنى لك التوفيق والسداد

ما شاء الله ...شرح رائع من شخص رائع... اسلوب مليئ بالحيوية و النشاط Energy

عدلت في الكود ... حمل الملف وجرب .. ان شاء الله يعمل ملاحظة: في الشيت Main يوجد تاريخ مكرر ل 1002 تم تعليمه بالاحمر شرح سريع للكود: Option Explicit Sub Button1_Click() Dim LR As Integer Dim i As Integer Dim sheetNum As Integer 'احصل على عدد الاسطر في الصفحة Main LR = [A1000].End(xlUp).Row 'احصل على الرقم الصفحة التسلسلي بطرح اسمها العددي (مثلا 1001) من 999 فيكن الناتج 2 لصفحة 1001 و 3 لصفحة 1002 و هكذا For i = 2 To LR sheetNum = Range("A" & i) - 999 ' تاكد من عدم و جود التاريخ في الصفحة المراد الترحيل اليها. If doesRecordExist(sheetNum, Range("B" & i)) = False Then ' اضف سطر جديد و ادفع اسطر الجدول للاسف Sheets(sheetNum).Range("A2:E2").Insert ' انسخ السطر من الجدول الرئيسي الى السطر الاول Range("A" & i & ":E" & i).Copy Sheets(sheetNum).Range("A2") ' احدف السطر رقم 7 للمحافضة على 5 اسطر فقط في كل جدول Sheets(sheetNum).Range("A7:E7").Delete End If Next i MsgBox "Êã ÇáÊÑÍíá ÈäÌÇÍ", vbInformation + vbOKOnly, "ÊÑÍíá ÇáÈíÇäÇÊ" End Sub ' دالة التأكد من عدم وجود التاريخ في الجدول المراد الترحيل اليه Private Function doesRecordExist(sheetNum As Integer, datDate As String) Dim LR As Integer Dim i As Integer Dim isFound As Boolean LR = Sheets(sheetNum).[A1000].End(xlUp).Row isFound = False For i = 2 To LR isFound = Sheets(sheetNum).Range("B" & i) = datDate If isFound Then Exit For Next i doesRecordExist = isFound End Function NEW 12.zip

هلا ابو ليد ممكن توضح اكثر .. وخصوصا التاريخ...ماذا تعني بالعبارة "لو افت عمود واحد" .. عذرا لم افهمها.. المقارنة تعتمد على قيمة العمود B

وعليكم السلام هلا ابو وليد جرب الكود المرفق. 12.zip

بعد اذنك اخي ibn_egypt هذا مثال اخر مع توضيح بعض المعادلات لتعبئة الجدول. Split a cell.zip

هلا ناصر ... هذا مثال للكتابة و القرأة من سجل النظام. عن طريق الكود سيتم انشاء مفتاح على المسار التالي: MyApp/subfolder/key1 Option Explicit Public Const APP_NAME As String = "MyApp" Public Const SECTION_NAME As String = "Subfolder" Public Const HD_SER_KEY As String = "key1" Public Const HD_SER_VALUE As String = "123456789" Public Const KEY_NOT_FOUND As String = "" Sub Button1_Click() 'انشئ او حدث قيمة المفتاح SaveSetting APP_NAME, SECTION_NAME, HD_SER_KEY, HD_SER_VALUE 'اقرأ قيمة المفتاح MsgBox GetSetting(APP_NAME, SECTION_NAME, HD_SER_KEY, KEY_NOT_FOUND) 'احذف مجلد البرنامج و جميع المجلدات الفرعية مع مفاتيحها DeleteSetting APP_NAME 'تأكد من صحة عملية الحذف If GetSetting(APP_NAME, SECTION_NAME, HD_SER_KEY, KEY_NOT_FOUND) = KEY_NOT_FOUND Then MsgBox "تم حذف المفتاح" End If End Sub

بالفعل اخي ياسر اوافقك الرأي ان الحماية في الاكسل ضعيفة و يمكن كسرها بسهولة و البرامج كثيرة اخي ناصر بالنسبة ل: اقترح عليك ان تحفظه في سجل النظام registry بعد تشفير المفتاح و عندها لن تحتاج ان تتعامل مع الملف النصي.

حياك الله ناصر معنى جملة Input As #1 هو فتح الملف للقرأة و 1# هو رقم مرجعي للملف (prices.txt) حيث استخدمنا هذا الرقم لقرأة سطر من الملف كما في الجملة Line Input #1, textline و اغلقنا الملف كما في الجملة Close #1

اخي ناصر ...ممكن فرض تفعيل الماكرو عن طريق اعلام المستخدم بذلك و في نفس الوقت اخفاء جميع الاوراق ماعدا ورقة واحدة. و عند تفعيل الماكرو تختفي هذه الورقة و تظهر بقية الاوراق. جرب المثال المرفق. Option Explicit Const SHEET_ENABLE_MACRO As String = "ENABLE_MACRO" Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim ws As Worksheet Sheets(SHEET_ENABLE_MACRO).Visible = xlSheetVisible For Each ws In ThisWorkbook.Worksheets If ws.Name <> SHEET_ENABLE_MACRO Then ws.Visible = xlVeryHidden End If Next ws ActiveWorkbook.Save End Sub Private Sub Workbook_Open() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Visible = xlSheetVisible Next ws Sheets(SHEET_ENABLE_MACRO).Visible = xlVeryHidden End Sub Enable Macros by force.zip

اخي الفاضل هذا مثال يقرأ من ملف نصي الى الاكسل. يمكنك بدلا من استخدام Try/Catch ان تستخدم On Error كما في الكود التالي: لتطبيق المثال حمل المرفق و تأكد ان ملف النص موجود في المسار D:\myData\prices.txt Sub btnReadTextFile() Dim myFile As String, text As String, textline As String Dim item As Integer, price As Integer, qty As Integer myFile = "D:\myData\prices.txt" On Error GoTo ErrHandler: Open myFile For Input As #1 Do Until EOF(1) Line Input #1, textline text = text & textline Loop Close #1 item = InStr(text, "المادة") price = InStr(text, "السعر") qty = InStr(text, "الكمية") Range("B3").Value = Trim(Mid(text, item + 8, 15)) Range("B4").Value = Mid(text, price + 7, 5) Range("B5").Value = Mid(text, qty + 8, 5) Exit Sub ErrHandler: MsgBox "لم يتم العثور على الملف ", vbCritical + vbOKOnly, "فتح ملف" End Sub MyData.zip

انظر اخي للرابط التالي: http://www.officena.net/ib/index.php?showtopic=56818