طارق محمود

السلام عليكم رددت أخي عليا علي الخاص سائلا نفس السؤال ورددت عليك "هل تعني أنه إذا كان Y1 = E2 فإن CLM1 = 5 وإذا كان Y2 = F2 فإن CLM2 =6 وهكذا ............... أي تريد قيم ثابتة للـ CLM حسب قيمة الـ Y" فأجبتني "بالظبط , هذا مأريده حيث ان رقم العمود E = 5 فقيمة CLM = 5 و رقم العمود F = 6 فقيمة CLM = 6 ما يهمني ان يكون ناتح قيم الستيب في العامود E تحت العامود E و مثله باقي القيم فاذا وجدت قيمة في الخلايا E2,F2,G2,H2,I2,......... نعتبرها الستيب, و يكون CLM هو رقم الحرف" فقط أحببت أنقل المحادثة لمن يريد المشاركة

السلام عليكم تفضل الملف بالأكواد فقط اضغط الزر ترتيب نتائج في الحلقة والمدرسة.rar

السلام عليكم الملف به مشكلتين المشكلة الأولي أسماء معرفة كثيرة جدا لاداعي لمعظمها + كثير منها يرجع لملفات أخري مثلا المجال (أو الإسم) FH هو عبارة عن ='C:\New Folder\[كشف حساب.xlsx]6'!$J$5:$J$7 أي يرجع للدرايف C ثم المجلد .. ثم ... ويأخذ قيمة من ملف آخر إسمه "كشف حساب.xlsx" من الورقة 6 وهكذا مثله كثيرا ، تجد قائمة بالأسماء في الشيت 4 من المرفق ولإصلاح هذا العيب ، تم إلغاء تلك الأسماء المشكلة الثانية في الورقة "حساب" بها معادلات كثيرة غير مباشرة ولحلها تم حذف الأسطر من بعد السطر 30 ويمكنك تثبيت البيانات التي أصبحت قديمة وتترك المعادلات في سطر واحد علي الأقل لتنسخ منه لتثبيت البيانات كما سبق: كوبي - بيست فاليو أي نسخ وقص خاص قيم فقط في نفس المكان تفضل المرفق بعد التعديل new_578645.rar

السلام عليكم أخي الكريم غير نهاية الكود من عند 'step-4 بالإضافة التالية 'step-4 [B1].EntireColumn.Delete '========================= c = WorksheetFunction.Search(".", NextFile) NewFile = Left(NextFile, c - 1) & ".xlsb" ActiveWorkbook.SaveAs Filename:=pt & "\" & NewFile, FileFormat:= _ xlExcel12, CreateBackup:=False ActiveWorkbook.Close 10 NextFile = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

السلام عليكم أولا: إذا كان بهذه الورقة كود يتحسس التغيير Private Sub Worksheet_Change(ByVal Target As Range) .. ... .. End Sub يمكنك إلغاؤه ولو مؤقتا مثلا إذا غيرت أول سطر إلي Private Sub Worksheeet_Change(ByVal Target As Range) أي فقط تضيف أي حرف مثل e لإسم الكود الخاص ليجعله ليس خاصا ثانيا : إذا لم يكن بهذه الورقة أكواد خاصة إذن بها بيانات كثيرة وعلاقات فمثلا إذا كانت الورقة بها 10,000 سطر يمكنك تعليم (إختيار) 9,500 سطربالأعلي ثم كوبي - بيست فاليو أي نسخ وقص خاص قيم فقط في نفس المكان بهذا تمنع اعاده الحساب كلما تم تغيير

السلام عليكم لدي برنامج (ليس مجاني - من الشركة التي أعمل بها) إسمه Able2Extratct يقوم بهذا بسلاسة إذا استطعت تحميله من عالنت أو إرسل لي الملف PDF وسأرسله لك - إكسل

(1) ليس مهما عدد الأسطر فقط كما أوضحت لك وعلي هذا سيأخذ البرنامج عدد الأسطر تلقائيا من الورقة (2) وبالنسبة لـ "فعل شيئ لجعله اسرع" نعم يمكنك إضافة سطرين للكود واحد بعد البداية مباشرة Application.ScreenUpdating = False والآخر قبل النهاية مباشرة Application.ScreenUpdating = True ليصبح الكود كالتالي Sub new_Change() Application.ScreenUpdating = False Application.DisplayAlerts = False pt = ActiveWorkbook.Path NextFile = Dir(pt & "\") Do While NextFile <> "" If NextFile = "Change.xlsm" Then GoTo 10 Workbooks.Open Filename:=pt & "\" & NextFile 'step-1 [D1:E1].EntireColumn.Delete 'step-2 LR = [B9999].End(xlUp).Row For r = 1 To LR If Cells(r, 2) = "" Or Cells(r, 3) = "" Or Cells(r, 2) = 0 Or Cells(r, 3) = 0 Or IsNumeric( _ Cells(r, 2)) = False Or IsNumeric(Cells(r, 3)) = False Then GoTo 20 If IsNumeric(Cells(r, 2)) Or IsNumeric(Cells(r, 3)) Then Cells(r, 4) = Cells(r, 2) - Cells(r, 3) 'step-3 Cells(r, 3) = Cells(r, 3) * 1000 20 Next r 'step-4 [B1].EntireColumn.Delete '========================= ActiveWorkbook.Save ActiveWorkbook.Close 10 NextFile = Dir() Loop Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub ولكن كما تقول 30,000 سطر لابد أن يأخذ وقتا وهذا التعديل سيسرع ذلك قليلا ممكن دقيقتين بدلا من 4 (3) أما السؤال نعم فالكود سيفتح أي ملف بالمجلد وهذا سينتج خطأ إذا كان بالمجلد ملفات لايمكن فتحها بالإكسل

السلام عليكم أخي العزيز هذا السطر LR = [B9999].End(xlUp).Row يعتمد علي البيانات بالعمود B فإذا كانت البيانات الأكثر لديك بالعمود F مثلا فلتغير الصيغة إلي LR = [F9999].End(xlUp).Row وإن كنت تريد تثبيت الرقم علي 999999 سطر فلتغير للتالي LR = 999999 ولكن هذا سيجعل التنفيذ بطيئا جدا لاأعتقد أنك تستخدم في ملف واحد أكثر من السطر 9999 أي تقريبا 10,000 بيان

السلام عليكم تفضل أخي الكريم الملف المرفق به ماطلبت ترتيب نتائج في الحلقة والمدرسة.rar

السلام عليكم أخي العزيز تفضل الملف المرفق به الكود المطلوب تضع الملفات كلها (المطلوب تعديلها) في مجلد واحد وتضع معهم هذا الملف المرفق لتشغيل الكود فقط افتح هذا الملف (بعد أن يكون في نفس المجلد مع الملفات الإكسل المطلوب تعديلها) ثم اضغط الزر الذي فيه سيتم إجراء التعديلات المطلوبة والحفظ والغلق لكافة الملفات الإكسل التي في نفس المجلد مع هذا الملف وهذا هو الكود Sub new_Change() Application.DisplayAlerts = False pt = ActiveWorkbook.Path NextFile = Dir(pt & "\") Do While NextFile <> "" If NextFile = "Change.xlsm" Then GoTo 10 Workbooks.Open Filename:=pt & "\" & NextFile 'step-1 [D1:E1].EntireColumn.Delete 'step-2 LR = [B9999].End(xlUp).Row For r = 1 To LR If Cells(r, 2) = "" Or Cells(r, 3) = "" Or Cells(r, 2) = 0 Or Cells(r, 3) = 0 Or IsNumeric( _ Cells(r, 2)) = False Or IsNumeric(Cells(r, 3)) = False Then GoTo 20 If IsNumeric(Cells(r, 2)) Or IsNumeric(Cells(r, 3)) Then Cells(r, 4) = Cells(r, 2) - Cells(r, 3) 'step-3 Cells(r, 3) = Cells(r, 3) * 1000 20 Next r 'step-4 [B1].EntireColumn.Delete '========================= ActiveWorkbook.Save ActiveWorkbook.Close 10 NextFile = Dir() Loop Application.DisplayAlerts = True End Sub ولابد أن يكون اسم الملف كما بالكود "Change.xlsm" تفضل Change.rar

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

لاأدري إن كنت مصيبا أم لا لكن جرب التعديل التالي في أول الكود بعد 4 أو 5 أسطر تجد الشرط التالي If Cells(Cells.Rows.Count, clm).End(xlUp).Row >= 5 Then Range(Cells(5, clm), Cells(Cells(Cells.Rows.Count, clm).End(xlUp).Row, clm)).Clear End If إحذفه ثم بعده بعدة أسطر تجد الأمر For r1 = 5 To endr إستبدله بالتالي For r1 = x+1 To endr ليكون الكود بعد التعديل هكذا Dim y1, y2, z, g, L, H Sub dd() Rw = 5 Y = Val(InputBox("برجاء ادخل قيمة step")) clm = Val(InputBox("براجاء ادخال رقم عمود النتيجة")) x = Cells(Cells.Rows.Count, clm).End(xlUp).Row كان هنا شرط تم إلغاؤه endr = Cells(Cells.Rows.Count, 1).End(xlUp).Row g = [B5] y1 = g - Y y2 = g + Y L = g H = g For r1 = x+1 To endr ... ..

السلام عليكم أخي الحبيب أكيد انك لن تريد عمل التدقيق (المراجعة) علي 50,000 سطر كما أوضحت لو كانت 30 ثانية كما تقول فهذا سريع وليس بطيء مع هذا الكم من البيانات أعتقد انك تتابع تغير أسعار شيء ما فلاداعي لمقارنة الأسعار كل يوم - كل يوم- كل يوم لنفس البيانات القديمة لعشر سنوات مضت لاأعرف ان كنت مصيبا ام مخطئا بعد المقارنة ومعرفة الناتج +up ، up+ ، down ، down ، ... وما إلي ذلك يمكن تثبيت هذه النتائج بما فيها من كومنتات إذن عليك تغيير الكود ليعمل بداية من آخر سطر به نتيجة من عمود النتيجة وليس من أول سطر

السلام عليكم أخي العزيز بعد إذن الإخوة تفضل المرفق بالشيت الثاني ستجد الآتي عدلت لك في طريقة إدخال البيانات ليتناسب مع إمكانيات الورقة في الاكسل عليك إدخال البيانات من العمود A إلي G ثم يتم الباقي تلقائيا ستجد أن الخلايا بأعمدة الإستلامات (وصول الدفعات) ستتلون تلقايا بالكحلي واطار أحمر عند وضع أي رقم بخلية الطلبية (العمود C) وذلك لتنبهك بعدم إدخال بيانات بهذه الخلايا ، حيث يكون هذا السطر لإدخال طلبية جديدة فقط ثم الأعمدة الخضراء (تاريخ الطلبية - فارق أيام - الشريحة) يتم حساب محتوياتها تلقائيا وأخيرا الخلية K2 والتي تمكنك من معرفة الباقي من الطلبية بمعلومية رقمها الذي تغيره أنت (يدويا أو من السهم) مثال على المطلوب2.rar

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

السلام عليكم الفكرة هنا تعتمد علي المدي الديناميكي فالرسم البياني الأول مثلا ، يعتمد علي نطاقين month1 ، sales2 النطاق الأول month1 يتغير بتغير الخليتين H4,I4 إذا ضغطت Ctrl-F3 لاستعراض الأسماء التي تم تعريفها بالملف ستجد أن النطاق month1 معرف كالتالي =INDEX(Month,MATCH(Sales!$H$4,Month)):INDEX(Month,MATCH(Sales!$I$4,Month)) وهذا يعني أنه يحفظ رقم العنصرداخل المجال Month والذي يحتوي علي ماهو موجود بالخليتين H4,I4 ويكون المحور الأفقي من الرسم هو المجال بين هذين العنصرين والنطاق الثاني sales2 بنفس الطريقة يمكنك تتبعه

السلام عليكم ماتفضل به اخونا الكريم / محمد أبو البراء ، مضبوط ولاأدري لماذا لايعمل معك عموما تفضل أخي المرفق به التعديل المصنف1_c.rar

السلام عليكم تفضل أخي المرفق وبه الكود التالي في حدث تغيير الإختيار بالورقة Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, [E10:E50]) Is Nothing Then v = Target.Value x = WorksheetFunction.CountIf([E9:E49], v) If x = 0 Then x = "" Else x = "" End If Shapes.Range(Array("مربع نص 2")).Select Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = x Target.Select End Sub المصنف1_b.rar

السلام عليكم أخي الكريم أولا : أنا غيرت عنوان الموضوع لكي لا يتم حذفه (لأنه مخالف لقواعد المشاركة) ثانيا: الملف الذي أرفقته أنت يحتوي علي دالة Table وهي ليست من دوال الإكسل علي حد علمي (حتي أوفيس 2010) ثالثا: طريقتك في البحث أوحت لي بالفكرة وبحثت أنا أيضا في المواقع الأجنبية ووجدت لك هذا الملف البسيط وإن شاء الله تفهم دواله (صفيف) الملف من العنوان التالي http://www.sumwise.com/blog/fifo/ ============================== أخيرا إليك شرح بسيط للملف طريقة FIFO إختصار لجملة إنجليزية ترجمتها الوارد اولا يصرف اولا first-in first-out (FIFO) في المثال عمليتين شراء بأسعار مختلفة وعمليتين بيع ونريد تحقيق المعادلة في الخليتين الأصفرتين بالصورة المرفقة والشرح بالتفصيل (بالإنجليزية) بنفس الرابط السابق FIFO.rar

السلام عليكم أخي العزيز تفضل المرفق ، إن شاء الله هو ماتريد الكود الموجود بالملف "0.xlsm" كالتالي Sub Tarheel() PT = ActiveWorkbook.Path Application.DisplayAlerts = False For sh = 1 To 10 nm = Format(sh, "@") Sheets(nm).Activate LR = [A9999].End(xlUp).Row With Sheets(nm) .Sort.SortFields.Clear .Sort.SortFields.Add Key:=[I2], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers With .Sort .SetRange Range("A2:N" & LR) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With Range("A1:N" & LR).Copy Workbooks.Open Filename:=PT & "\" & nm & ".xlsm" Sheets("maindata").Select Range("AA1").Select ActiveSheet.Paste ActiveWorkbook.Close (True) Next Application.DisplayAlerts = True End Sub kinguter.rar

السلام عليكم تفضل اخي أرجو أن يكون هو ماتريد 777_Adjusted.rar

الباسورد للبرنامج ولمحرر الأكواد هو 123

السلام عليكم أخي / باسم الموضوع سيأخذ وقتا طويلا كما أخبرتك إليك بعض التحسينات الممكن عملها علي الملف (1) عمل ورقة مجمعة بها بيانات السيارات وليكن اسمها DataBase ويكون بها أرقام السيارات ونظام الحساب المتفق عليه (يومي / أسبوعي / شهري) من المعروف أن الإيجار اليومي يقل إذا تم تأجير السيارة أسبوع أو أكثر في هذه الورقة DataBase يتم ربط أرقام السيارات بورقاتها بحيث أنك تضغط علي رقم السيارة فتتحول تلقائيا لصفحتها (2) في ورقة السيارة ، بمجرد اختيار نوع الحساب المتفق عليه (يومي / أسبوعي / شهري) ، تحصل تلقائيا علي فئة الإيجار المقابلة (3) تلوين أوتوماتيكي لحالات الايجار غير اليومي (4) عمل جدول خاص للمخالفات ثم إستدعاؤها ووضعها في مكانها بالجدول الخاص بالسيارة أنظر المرفق fastertry11111111111.rar

السلام عليكم أخي العزيز / باسم إن شاء الله سأساعدك ولو بالقليل مما تطلب ولكن شأني كشأن جميع الأعضاء هذا لوجه الله الكريم فلاداعي لقول "هناك أجر يحدده لا مانع لدينا من ذلك" ============================ لنبدأ أولا من هيكل الملف الذي أرسلته (1) أفهم منه أن لكل سيارة شيت (ورقة) منفصل فهمت ذلك من المثال الذي أعطيته أنت للسيارة KIA PICANTO C 14679 العمود F به عدد أيام الإيجار ، معادلة حساب عدد الأيام بها خطأ حسب فهمي أن شركات التأجير تحتسب يوم البداية ويوم النهاية بمعني لو أنني أجرت سيارة اليوم ورددتها غدا سيحتسب يومين إيجار (2) العمود C به قيمة الإيجار اليومي ، هل هذا طبيعي أن تكون نفس السيارة إيجارها لشخص 100 ثم لشخص آخر500 أم أن هذا مثال أم أنني لم أفهم ============================ ثانيا : أحب أن تعرف أن الموضوع سيطول حيث أنني غير متواجد بالموقع إلا نادرا نظرا لظروف عملي إلا أن يتدخل معنا أحد الأعضاء حسب وقته ============================ ثالثا : إن كان لك علاقة بشركات الإيجار الكبري القريبة منك ، تستطيع شراء نفس البرنامج المستخدم لديهم ، قد يكون أفضل كثيرا لتوفير الوقت ولملائمة مثل هذا البرنامج تماما لما تريد كنت قد أجرت منذ أكثر من 4 سنوات من شركة Diamond Lease في جبل علي - دبي ورأيت البرنامج الذي يعملون عليه ، بصراحة شيء رائع هذه الشركة لديها مايزيد عن خمسة آلاف سيارة وبدون مثل هذا البرنامج لن يستطيعوا السيطرة علي شيء إن شاء الله يبارك لكم في شركتكم وتكونون أكبر منها إسأل أحد العاملين بالشركة قد يكون البرنامج رخيصا وأسهل من كل هذا مازلت محتفظ برقمهم : 04.8852211 إن لم يكن تغير مع الزمن وهذا موبايل احد المسؤلين هناك 050.4698334 ========================== مع تمنياتي بالتوفيق والسداد

السلام عليكم أخي العزيز يلزمك عدة خطوات أولا: نسخ كود فك الحماية في جميع الورقات ولعمل ذلك 1- إنسخ الكود التالي في الملف عندك Sub copy_Button() nm = ActiveSheet.Name Selection.Copy For i = 1 To Sheets.Count If Sheets(i).Name = nm Then GoTo 10 Sheets(i).Select ActiveSheet.Paste 10 Next End Sub 2- إلغي الحماية عن الشيتات جميعها 3- أضف زر في إحدي الشيتات وعين له الكود الخاص بفك الحماية 4- كليك يمين علي الزر بعد تعيين الكود له ثم شغل الكود الذي نسخته في الخطوة 1 ثانيا : تضع كود الحماية في حدث يخص الملف كله عند تنشيط أي ورقة هكذا Private Sub Workbook_SheetActivate(ByVal Sh As Object) Cells.Select Selection.Locked = False Selection.FormulaHidden = False Selection.SpecialCells(xlCellTypeFormulas, 23).Select Selection.Locked = True Selection.FormulaHidden = False ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub وبهذه الطريقة كلما انتقلت لورقة جديدة سيتم حمايتها أوتوماتيكيا ثم يمكنك فك الحماية من الزر الذي تم ترتيبه سابقا إليك المرفق وبه الخطوات مفعلة المخزن.rar