طارق محمود

السلام عليكم أخي الكريم 1- سأغير عنوان الموضوع ليكون ملتزما بقواعد المشاركة أرجو الالتتزام في المستقبل 2- تفضل المرفق به ماطلبت وأكثر تجربة.rar

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

وجدت علي الشبكة ملف قد يفيد http://www.4shared.com/get/L8rF7n8tba/Wind_Speed_Data.html

جائني السؤال التالي علي الخاص ======================= 1-اريد طريقه لايجاد التكرار لسرعة الرياح المقاسه كل عشر دقائق لمدة سنه كامله. 2-كيف نحسب الانحراف المعياري لنفس الداتا. شكرا ========================== أحببت أن أضعه ليتاح للأعضاء المهتمين الاستفادة والمشاركة أيضا

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

"كيف تم التعديل" ================ تم التعديل علي خطوتين الخطوة 1- ظلل المجال F3:F20 الذي به الأرقام ثم استبدل كل الفاصلات (الكومة) بلاشيء لعمل ذلك بعد التظليل إضغط Ctrl-H بالمستطيل العلوي تستبدل ماذا اكتب له , ثم بالمستطيل الأسفل تستبدلها بماذا فلاتكتب شيء فيه ونفذ الأمر سيعيد تلك الاشكال إلي صيغتها الرقمية الخطوة 2- من التنسيق لنفس المجال إختر تنسيق خاص Custom ثم اكتب الصيغة 0,000.00

السلام عليكم أخي الكريم هذه ليست أرقام الأرقام إذا وقفت عليها تجد قيمتها بأعلي الجدول وليس شكلها تم تعديلها لتكون أرقام تفضل المرفق 00-2.rar

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

أخي الريفي جزاك الله كل خير الفكرة جميلة فعلا لك كل الاحترام والتقدير

السلام عليكم الأخ الحبيب / engreda عندك حق لقد خانني التعبير ============ والأدق أنني لم أجد التفاعل وليس التشجيع ، لو راجعت تواريخ المشاركات ستجد أنني بدأت في أول 2008 (كان عمري وقتها 45 والآن 51 ) وانقطعت تقريبا بعد 6 أشهر من التفاعل الضعيف ثم سألني أخي وصديقي م/شريف عبد الباسط سؤال في الموضوع بعد 4 سنوات من طرحه فأجبته وقتها وبعد ذلك لم يتفاعل أحد مع الموضوع اللهم إلا الأخ / Baher Mostafa في أوائل هذا العام ثم حضرتك اول أمس ثم أنني لم أكن قد أعددت موضوعا متكاملا ، فقط ظننت أن هذا النوع من العلوم قد يفيد بعض المهندسين ولم أعد موضوعا متكاملا بل حلقات كنت أقوم بإعدادها في وقتها وقد أصبح أن هذا الطرح قديما نسبيا بعد كل هذه المقدمة يؤسفني أخبرك أنني شخصيا قد بعدت كثيرا عن الموضوع حيث أخذتني مشاغل الحياة وقد أحتاج وقت حتي أراجع ماكتبت سابقا ثم أستطرد فيه مرة أخري وللأسف لاأملك الوقت حاليا ولكن إن يسر الله لي الوقت ، فسأفعل بإذن الله

باسوورد الحماية؟؟

السلام عليكم جزاك الله خيرا اخي الفاضل الأستاذ / جمال عبد السميع وحفظك الله من كل سوء وجعلنا عند حسن ظنكم

السلام عليكم أخي الكريم تفضل الملف وبه المطلوب 22_2.rar

السلام عليكم أخي الكريم تفضل الملف به ماطلبت برامج ولجان2.rar

السلام عليكم أخي الحبيب أولا بالنسبة لمقاس الشيك قابلتني مشكلة مشابهة وحللتها كالتالي صور عدة نسخات للإستخدام والتضبيط قطع الصور المنسوخة لتكون نفس مقاس الشيك جهز بيانات لشيك وهمي علي الإكسل حاول الطباعة عدة مرات مع تغيير هوامش الصفحة في الإكسل ومقاس الورقة علي الطابعة ستنجح إن شاء الله بعد محاولتين أو ثلاثة ثانيا بالنسبة للتفقيط إليك هذا الكود تغير فيه العملة والوحدات كما تشاء ثم تضعه في إعدادات الاكسل علي الجهاز وهذا الكود ليس من أعمالي أنا نسخته من المنتدي (قد يكون لأستاذنا النابغة / عبدالله باقشير) Function SpellNumber(ByVal MyNumber, _ Optional pbNum As Boolean = True, _ Optional ptCur As String = "Yuan", _ Optional ptDec As String = "Jiao", _ Optional ptPlu As String = "") Dim Curr, Decm, Temp Dim DecimalPlace, Count Dim vtPHolder As String ReDim Place(9) As String Place(2) = " Thousand " Place(3) = " Million " Place(4) = " Billion " Place(5) = " Trillion " '' String representation of amount If Mid(MyNumber, 1, 1) = "-" Then MyNumber = Mid(MyNumber, 2, Len(MyNumber) - 1) End If MyNumber = Trim(Str(MyNumber)) '' Position of decimal place 0 if none DecimalPlace = InStr(MyNumber, ".") '' Convert decimal part, and set MyNumber to currency amount If DecimalPlace > 0 Then vtPHolder = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2) If pbNum = True Then Decm = GetTens(vtPHolder) Else Decm = vtPHolder End If MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" Temp = GetHundreds(Right(MyNumber, 3)) If Temp <> "" Then Curr = Temp & Place(Count) & Curr If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Curr Case "" Curr = "" Case "One" Curr = "One " & ptCur Case Else Curr = Curr & " " & ptCur & "" End Select Select Case Decm Case "" Decm = "" Case "One", "01" If Curr = 0 Or Curr = "" Then Decm = Decm & " " & ptDec Else Decm = " and " & Decm & " " & ptDec End If Case Else If Curr = 0 Or Curr = "" Then Decm = Decm & " " & ptDec & ptPlu Else Decm = " and " & Decm & " " & ptDec & ptPlu End If End Select SpellNumber = Curr & Decm End Function '******************************************* ' Converts a number from 100-999 into text * '******************************************* Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) 'Convert the hundreds place If Mid(MyNumber, 1, 1) <> "0" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred " End If 'Convert the tens and ones place If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & GetTens(Mid(MyNumber, 2)) Else Result = Result & GetDigit(Mid(MyNumber, 3)) End If GetHundreds = Result End Function '********************************************* ' Converts a number from 10 to 99 into text. * '********************************************* Function GetTens(TensText) Dim Result As String Result = "" 'null out the temporary function value If Val(Left(TensText, 1)) = 1 Then 'If value between 10-19 Select Case Val(TensText) Case 10: Result = "Ten" Case 11: Result = "Eleven" Case 12: Result = "Twelve" Case 13: Result = "Thirteen" Case 14: Result = "Fourteen" Case 15: Result = "Fifteen" Case 16: Result = "Sixteen" Case 17: Result = "Seventeen" Case 18: Result = "Eighteen" Case 19: Result = "Nineteen" Case Else End Select Else 'If value between 20-99 Select Case Val(Left(TensText, 1)) Case 2: Result = "Twenty " Case 3: Result = "Thirty " Case 4: Result = "Forty " Case 5: Result = "Fifty " Case 6: Result = "Sixty " Case 7: Result = "Seventy " Case 8: Result = "Eighty " Case 9: Result = "Ninety " Case Else End Select Result = Result & GetDigit(Right(TensText, 1)) 'Retrieve ones place End If GetTens = Result End Function '******************************************* ' Converts a number from 1 to 9 into text. * '******************************************* Function GetDigit(Digit) Select Case Val(Digit) Case 1: GetDigit = "One" Case 2: GetDigit = "Two" Case 3: GetDigit = "Three" Case 4: GetDigit = "Four" Case 5: GetDigit = "Five" Case 6: GetDigit = "Six" Case 7: GetDigit = "Seven" Case 8: GetDigit = "Eight" Case 9: GetDigit = "Nine" Case Else: GetDigit = "" End Select End Function Sub list_sheets() For i = 1 To Sheets.Count ActiveCell(i, 1) = Sheets(i).Name Next End Sub

السلام عليكم رددت أخي عليا علي الخاص سائلا نفس السؤال ورددت عليك "هل تعني أنه إذا كان 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