نجوم المشاركات

السلام عليكم ورحمة الله وبركاته يسعدنى المشاركة معكم فى هذا الموضوع الشيق أولا : فى حالة وجود الفراغات نستخدم هذا الكود Sub Transpose_RG() Dim i As Integer Dim LR As Integer Dim arr() As Variant '============================================================= [B1:B1000].ClearContents LR = Cells(Rows.Count, 1).End(xlUp).Row ReDim arr(1 To LR) '============================================================= For i = LR To 1 Step -1 arr(LR + 1 - i) = Cells(i, 1) Next [B1].Resize(LR) = Application.WorksheetFunction.Transpose(arr) End Sub وفى حالة اهمال الفراغات نستخدم الكود التالى Sub Transpose_RG() Dim i As Integer Dim ii As Integer Dim LR As Integer Dim arr() As Variant '============================================================= [B1:B1000].ClearContents LR = Cells(Rows.Count, 1).End(xlUp).Row '============================================================= For i = LR To 1 Step -1 If Not IsEmpty(Cells(i, 1)) Then ii = ii + 1 ReDim Preserve arr(1 To ii) arr(ii) = Cells(i, 1) End If Next [B1].Resize(ii) = Application.WorksheetFunction.Transpose(arr) End Sub Transpose.rar Transpose2.rar

أخي الكريم الغالي ياسر العربي كثر المنادون عليك فهلا أجبت لهم النداء .. !

ال السّلام عليكم ورحمة الله وبركاته أخي الحبيب عبد العزيز: إخوتي الكرام إذاً نحن متفقون على استكمال ما بدأ به أخونا الحبيب أبو أسيل نرجع كلنا على المصطبة ونستضيف معنا الأخ أحمد الفلاحجي والبط راح يكون أطيب الموائد عند صاحب الكرم والجود ... مرحباً بكم بالمصطبة العامرة بالأحباب ..والسلام عليكم.

هنا اختصار للكود Sub معاينة_مع_الطباعة() ActiveWindow.SelectedSheets.PrintPreview If MsgBox("هل تود الطباعة بعد المعاينة؟", vbYesNo + vbQuestion, "طباعة") = vbYes Then ActiveSheet.PrintOut End Sub

بارك الله قيك اخي الفاضل رجب و اسمح لي باضاقة بسيطة على الكود ليتجنب التكرار و يصبح هكذا Sub Transpose_RG1() Dim i As Integer Dim ii As Integer Dim LR As Integer Dim arr() As Variant '============================================================= [B1:B1000].ClearContents LR = Cells(Rows.Count, 1).End(xlUp).Row '============================================================= For i = LR To 1 Step -1 x = Application.WorksheetFunction.CountIf(Range("a1:a" & i), Cells(i, 1)) If x > 1 Or Cells(i, 1) = Empty Then GoTo 1 ii = ii + 1 ReDim Preserve arr(1 To ii) arr(ii) = Cells(i, 1) 1: Next [B1].Resize(ii) = Application.WorksheetFunction.Transpose(arr) End Sub

أضحكتني ...أضحك الله سنك .. عليك بتلاوة الزهراوين والإخلاص والمعوذتين ....لتطرد عنك هؤلاء العفاريت.

إذا كان على شغل العفاريت فأنا بقالي نص ساعة بدور على موضوع الأسبوع اللي فات "استخراج الصور" ومش لاقيه .. يبدو أنه حذف عن طريق الخطأ .. المشكلة مش في كدا ..دخلت على الموضوعات المحذوفة مش لاقيه .. يبدو إنه فيه فعلاً قطط تتح بتلعب في المنتدى !! ربنا يستر وميجبوش ضلفها

السّلام عليكم و رحمة الله و بركاته أخي الحبيب " أحمد الفلاحجي " .. سأروي لك حكاية ليلة من إحدى ليالي 1000 ليلة و ليلة : أشتغل على WINDOWS 8 BUILD 9200 32 بايت .. أردت عمل باكاجْ لأحد المشاريع التجريبية .. على نسخة الفيجوال بيسك البروفيسيونال أعمل الحفظ EXE .. ثم بمجرّد الانتقال إلى الباكاج .. تعلق الماوسْ و تبدأ تدور إلى ما لا نهاية من الوقت .. إستفسرت عن سبب ذلك .. و لكل رأيه .. http://vb4arb.com/vb/thread-15121.html حذفت الوينداوز 8 .. و قمت بتسطيب الاكس بي .. بمنتصف التسطيب .. علقت .. و لم تكتمل .. ال CD .. لست أعرف ما به فكرت بالويندوز 7 .. قمت بتسطيبها .. و يا ريت ما قمت بذلك المشروع إتلخبط .. و عند فتحة كل المكتبات لم يتعرف عليها .. أحسست أن هذ الويندوز 7 سيدخلني بدوامة قلت بنفسي .. الرجوع إلى الأصل فضيلة .. الويندوز 8 أشتغل عليها منذ حوالي سنتين .. سأرجع إليها .. و كرهت المشروع المفاجأة أني لما أعدت تسطيب الويندوز 8 .. رجع الباكاجْ يعمل بطريقة ممتازة و سليمة ألف بالمئة هذا الفيجوال بيسك .. أرهقني كثيرًا فائق إحتراماتي السّلام عليكم و رحمة الله و بركاته أخي الحبيب الغالي " ياسر العربي " إشتقت لك و لكل حبايبي ..أولئك الذين أحببتهم في الله إشتقت للأيام الحلوة .. و لإبداعك المستمر نحن بالانتظار رجاء .. متطولش علينا كثيرًا إحتراماتي

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

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

حياك الله .. تفضل mosadd: nz(DSum("[amount]";"payment";"[student_ser]=" & [student_ser] & " and [year_code]=2");0) بالتوفيق

و عليكم السلام و رحمة الله وبركاته اخي الفاضل جرب المرفق في العمود الأول ادخل اسم المشروع تظهر لك بياناته ان كانت موجودة لإستخراج بيانات محددة من نفس الورقة في اعلى الورقة في الخانة الصفراء F1 اكتب اسم المشروع تظهر لك كل بيانات هذا المشروع فقط امسح البيانات من F1 تظهر لك كل البيانات الكود المستخدم Private Sub Worksheet_Change(ByVal Target As Range) Dim TR, TC, ER, FR, CC TR = Target.Row TC = Target.Column If TR > 3 And TC = 1 Then ER = Sheets("sheet2").UsedRange.Rows.Count For FR = 1 To ER If Sheets("sheet2").Cells(FR, 1) = Sheets("sheet1").Cells(TR, 1) Then For CC = 2 To 5 Sheets("sheet1").Cells(TR, CC) = Sheets("sheet2").Cells(FR, CC) Next CC End If Next FR End If If TR = 1 And TC = 6 Then Dim RN As Range ER = ActiveSheet.UsedRange.Rows.Count Set RN = Range("A3:I" & ER) CC = Cells(TR, TC).Value If CC = "" Then RN.AutoFilter Else RN.AutoFilter Field:=1, Criteria1:=CC End If Cells(TR, TC).Select End If End Sub مع التحية expenses--az.rar

التقويم السنوى يمكن من خلال المرفق طباعة التقويم السنوى وتقريبا انا عملته حتى عام 2044 يا مين يعيش التقويم السنوي.rar

بسم الله الرحمن الرحيم اخوانى اصدقائى اعضاء المنتدى الكرام السلام عليكم ورحمة الله وبركاتة اقدم لكم اليوم درس جديد فى vba ودة كان ردا على سؤال احد الاخوة https://youtu.be/jLLXfCYzCvE فتح الشيتات من خلال الكومبو بوكس.rar

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله الموضوع ليس موضوع علمي إنما هو تسويق لشغل للمدارس الثانوية .. عايز نلم الجرشينات ونحاول نعوض الوقت اللي بقضيه في تعلم البرمجة خدمة عمل كشوف 150 د ثانوية عامة ، حيث يتم تصدير البيانات من على الموقع إلى ملف إكسيل جاهز للطباعة وقابل للتعديل .. الخدمة مقابل 10 جنيهات فقط (يعني يدوب حق كارت شحن ... يا بلاااااااااااااااااااااااش ) مرفق صورة للشكل المخرجات التي سيتم تسليمها لمن أراد الخدمة التسليم يتم في خلال نصف ساعة فقط .. عن طريق الإيميل أو الفيس بوك أو أي وسيلة أخرى مناسبة للعميل للاتصال : Facebook : yakh777@yahoo.com Mobile : 01281054545 وتقبلوا وافر تقديري واحترامي والسلام عليكم ورحمة الله وبركاته

اشكرك استاذي الكريم سعيد .. كلها تعمل بشكل سليم الا مجموع الاستعلامات CurrentDb.QueryDefs.Count بحيث ان عندي في قاعدة البيانات استعلام واحد .. لكن يظهر في المجموع 267 ؟!! اضحك الله سنك لي غرض احصائي في برنامجي فاحتاج لمعرفة الاعداد بدون استخدام العد على الاصابع وحيث اني بحثت عن هذه المعلومة التي خطرت على بالي في المنتدى ولم أجد شخص قد تطرق لها وجدت الحل CurrentData.AllQueries.Count

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

رائع كعادتك اخى سليم جزاك الله خيرا تقبل تحياتى

انسخ هذه المغادلة الى الخلية E6 واسحب نزولاً =IFERROR(IF(A6="","",SUM(B6*D6)),D6)

هههههههه وممكن انم تعدهم وتحسبهم لكن لى سؤال ما الفائدة من هذا المطلب الغريب

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

هههههههههههههههه انا اسف اخى عبده الزهايمر هيشتغل باين كده اتفضل ياغالى http://www.dev-point.com/vb/t385482.html تقبل تحياتى

تمام يا ابوالبراء جزاك الله كل خير

السلام عليكم ورحمة الله وبركاته نبتعد قليلاً عن أسلحة الدمار الشامل .. وننتقل إلى ملف ذو فائدة كبيرة إن شاء الله معكم اليوم : دانلود مانجر داخل الإكسيل ..حمل ملفاتك وعيش حياتك وانسى التفعيل والكراكات .. طبعاً لا بديل عن الداونلود مانجر في تحميل الملفات ، ولكن ملف اليوم ممكن يكون بديل مؤقت ، عشان لو حصلت مشكلة في التحميل متعطلش !! أترككم مع رابط الفيديو لكيفية استخدام البرنامج .. تقبلوا تحيات أخوكم أبو البراء ودائماً إن شاء الله مع كل جديد ومفيد دمتم على طاعة الله Download Internet Files Automatically.rar

السّلام عليكم و رحمة الله و بركاته الأخَوان الفاضلان "محمد حسن المحمد" "أحمد الفلاحجي" فعلا كانت أيام جميلة .. ياريت ترجع .. الأخ الغالي " ياسر العربي " .. ربما لظروف قاهرة منعته من إتمام المسيرة معنا البركة فيكما بإمكانكما إرجاعنا للزّمن الجميل بالنسبة لسؤال الأخ الكريم " أحمد الفلاحجي " ..قمت بتحميل النسخة البورتابل مند أسبوع .. صغيرة الحجم .. كنت أحسب أنّي " جبت الأسد من أذنه .. لكن يا فرحة ما تمّت ..فهي لا تصلح لشيء إحتراماتي

شرفتم الموضوع إخواني وأحبابي في الله .. والحمد لله أن نال إعجابكم وأرجو أن تستفيدوا منه

السلام عليكم عمل ناجح ومتميز ...تمت التجربة بنجاح100% جزاكم الله خيراً..أخي المعطاء أبو البراء والسلام عليكم.

ياريت لانى ما اخدتش حقى من المصطبه ولا هي جت عليا والحكومه عملت ازاله

أستاذ سعيد صواب أشكرك فقد عملت الدالة وجزاكم الله خيرا .

السلام عليكم بهد اذن اخي و صديقي احمد اليك هذا الملف الذي يغمل بالمعادلات مع الاشارة الى ان القوائم المنسدلة مطاطة(تستجيب لاي تغيير في البيانات ولا تذكر المكرر الا مرة واحدة) expenses salim.rar

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

شوف الفيديو ده لعله يفيدك تقبل تحياتي

أعتقد بالنسبة للفيديوهات أمرها صعب شوية خصوصاً اليوتيوب .. فيه إضافة للفايرفوكس جميلة جدا اسمها Video Download Helper بتجيب لك الروابط الخاصة بالفيديو بكل الأحجام .. https://addons.mozilla.org/en-US/firefox/addon/video-downloadhelper/ دا الرابط الخاص بالإضافة

هذا الكود يقوم بملء الخلايا الخالية فى العمود المختار ، بنفس القيمة الموجودة فى اول خلية ، الي أن يصل الي خلية بها قيمة ، فيقوم باستخدام القيمة الجديدة وهو مفيد فى الحالة التالية مثلا ان العمود الاول مكتوب به البلد مرة واحدة ، و امامها عدة اسطر للموظفين ثم البلد التالية بعد عدة أسطر و هكذا و تريد فى قائمة طويلة مليء البلد امام كل موظف ، فما عليك الا التعليم علي اخلايا فى العمود المطلوب ملؤه ثم تشغل الماكرو التالي : ( راجع المثال لتكون الصورة أوضح ) :) Sub FillEmptyAsAbove() ' ' deleteemptyRow Macro ' Macro recorded 19/07/2000 by taher to delete empty rows in aselection Application.ScreenUpdating = False Dim MyRow As Long, origraw As Long ' Z As String MyRow = Selection.Rows.Count origraw = MyRow ActiveCell.Select 'MsgBox MyRow For i = 1 To MyRow - 1 'If ActiveCell.Value <> "" Then ActiveCell.Offset(1, 0).Activate If ActiveCell.Offset(i, 0).Value = "" Then 'ActiveCell.EntireRow.Delete 'MyRow = MyRow - 1 ActiveCell.Offset(i, 0).Value = ActiveCell.Offset(i - 1, 0).Value End If Application.StatusBar = "Parsing / deleting ...." & _ Format(i / origraw, "0.0%") & " Please Wait......." Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub Fill_all_empty.zip

عودة النسر الباشمهندس علي السحيب حفظه الله وبارك فيه من عمالقة المنتدى يتميز اسلوبه بالسهل المفيد ولغة مخاطبته للناس راقيه جدا ... ارجو ان تعطوه منزلته وقدره الكريم من الاحترام اعطوا الناس منازلهم ودعاؤنا لله ان يجعله عودا حميدا للمنتدى واحبابه

حاول اخى ان ترفق الملف حتى ولو لم يفتح معك

حياك الله وجدت لك هذه الطريقة جرب ووافنا بالنتائج 'Number of Tables CurrentDb.TableDefs.Count 'includes system tables 'Number of Queries CurrentDb.QueryDefs.Count 'Number of Forms Currentproject.AllForms.Count 'Number of Macros Currentproject.AllMacros.Count 'Number of Reports Currentproject.AllReports.Count 'Number of Modules Currentproject.AllModules.Count 'does not include object modules بالتوفيق

أخي الكريم جرب الكود التالي Sub Test() Dim A, I As Long, II As Long A = Sheets("ALL").Cells(1).CurrentRegion.Value With CreateObject("Scripting.Dictionary") For I = 1 To UBound(A, 1) If Not .exists(A(I, 1)) Then .Item(A(I, 1)) = .Count + 1 For II = 1 To UBound(A, 2) A(.Count, II) = A(I, II) Next Else If A(I, 3) > A(.Item(A(I, 1)), 3) Then For II = 2 To UBound(A, 2) A(.Item(A(I, 1)), II) = A(I, II) Next II ElseIf A(I, 3) = A(.Item(A(I, 1)), 3) Then A(.Item(A(I, 1)), 2) = Application.Min(A(.Item(A(I, 1)), 2), A(I, 2)) End If End If Next I = .Count End With Sheets("DATA").Cells(1).Resize(I, UBound(A, 2)).Value = A End Sub تقبل تحياتي

جزاك الله كل خير تسلم ايدك ياغالى انا عملتلك نيش مخصوص للاعجابات بما إن إحنا مشهورين بالاثاث ههههههههههههه حبيبى يا ابوالبراء

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

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

السلام عليكم ..الآن استوعبته ...جزاكم الله خيراً وجعلكم وذريتكم صالحين ناصحين ..آمين هذا الملف مفيد لي في عملي لأنني كثيراً ما أحتاجه... والسلام عليكم ورحمة الله وبركاته

جرب التالي =MID(CELL("filename",A1),FIND("]",CELL("filename",A1))+1,255)

وعليكم السلام ورحمة الله وبركاته أستاذى وأخى الحبيب نصيخة غالية ستوضع بعين الاعتبار ان شاء الله ولكن لا علاقة بنسخة الويندز فهى من ضمن المتطلبات كما بالصورة وأبشرك فقد وجدت الحل والحمد لله بهذه المقالة: https://social.msdn.microsoft.com/Forums/sqlserver/ar-SA/bb9866a8-dbf5-453e-8aaa-afd66fb48403/sql-2008-r2-sp1-updete-failed-kb2528583-error-code-84b40000?forum=sqlsetupandupgrade وتم التصطيب بنجاح والحمد لله .

جزاك الله خير استاذ محمد اي كود تقصد شكرا

اتفضل اخى واستاذى ياسر اليك حلا اخر {=INDEX($A$1:$A$6,LARGE(ROW($A$1:$A$6),ROW($A1)))}

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

أخي الكريم سامح جرب الكود التالي Sub LoopThroughClosedWBs() Dim WBK As Workbook Dim FolderPath As String Dim FileName As String Dim Counter As Double Dim Sh As Worksheet 'ضع المصنف الذي يحتوي الكود في نفس مسار الملفات المراد العمل عليها FolderPath = ThisWorkbook.Path & "\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Do While FileName <> "" If FileName <> ThisWorkbook.Name Then Application.Calculation = xlManual Set WBK = Workbooks.Open(FolderPath & FileName) With WBK.Sheets("Sheet1") .Range("E1").Formula = "=SUM(A1:B1)" End With Application.Calculation = xlAutomatic WBK.Close SaveChanges:=True End If FileName = Dir() Loop Application.Calculation = xlAutomatic Application.ScreenUpdating = True MsgBox "Finished ...", 64 End Sub في السطر قبل حفظ وإغلاق المصنف يتم وضع السطر التالي Application.Calculation = xlAutomatic تقبل تحياتي

و عليكم السلام و رحمة الله و بركاته أغرب ما فى موضوعك أخى الكريم ان استجابتك جاءت بعد أكثر من عامين من طرحه ، لقد دهشت كثيرا لهذا الامر عموما فضلا لا أمرا أرجو منك الأطلاع على موضوع التوجيهات بالرابط التالى http://www.officena.net/ib/index.php?showtopic=60147 بخاصة التوجية الحادى عشر .. دمت بخير و أعزك الله.

جميلة لكن يمكن قطع لسان DNM نهائيا وما يتكلمش أبدا معاك ويحمل لا مؤاخذة زى الــــــــ بالفكرة دى قائمة ستارت RUN اكتب REGEDIT OK YES لفتح محرر الريجسترى HKEY_CURRENT_USER Software DownloadManager دوبل كليك فى النافذة المقابلة نجرى تعديلات دوبل كليك على CheckUpdtVM خلى قيمتها 0 دى تمنع البرنامج من البحث عن تحديتات دوبل كليك على LastCheck فرغ قيمتها نهائيا دى تمنع البرنامج من تسجيل آخر بحث عن تحديتات قفل النوافذ وأعد تشغيل الجهاز أنا عملت كده منذ فترة كبيرة والبرنامج تجريبى ويعمل بكامل صلاحياته ولم يفتح فمه من ساعتها تحياتى