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

اساتذتى الافاضل فى هذا الصرح العلمى كثيرا ما نواجه عناء وتعب الاختيار من القائمه للكمبوبوكس خاصه لو كان القائمة تحتوى على 2000 صف مثلا فيكون الاختيار من القائمة امر شاق ومرهق واستمراراً فى البحث عن ابتكار شئ جديد يفيدنا جميعا أقدم لكم اليوم كود فى حدث تغيير الكمبوبوكس لحل هذه المشكله وتوفر علينا عناء البحث بمجرد كتابة حرف ( عربى او انجلش) او رقم او علامه مثل ( & * / # وغيرها ) ستجد الكمبوبوكس تم فلترة القائمه طبقا لما تريد البحث عنه أقدمه لكم صدقه جاريه على روح المغفور له بأذن الله استاذى / عماد الدين الحسامى لا تنسوا الفقيد من صالح دعائكم اسال الله تعالى ان يتغمده بواسع رحمته تقبلوا تحياتى اخوكم وتلميذكم / حسام كمبوبوكس طبقا للبحث - الصقر.zip

السلام عليكم ورحمة الله وبركاته أخى أبو يوسف جرب هذا الكود حساب عدد التكرار لكل مكتب في جميع الاوراق و أبدى ملاحظاتك Option Explicit Sub CopyToNewSheet() ' by Mokhtar Hussien ' 25/11/2015 Dim SH As Worksheet Dim P As Long Dim Rng As Range Dim Data, ColFound Dim Obj As Object Application.ScreenUpdating = False Application.DisplayAlerts = False '----------------------------------------------------------------- Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "التجميعى" '----------------------------------------------------------------- For Each SH In ThisWorkbook.Sheets If IsError(Application.Match(SH.Name, Array("Master", "التجميعى"), 0)) Then SH.Range("M2").CurrentRegion.Offset(1).Copy With Sheets("التجميعى") .Activate .Range("B1:C1") = Array("مكتب التربية", "العدد") .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll With .Range("B1").CurrentRegion .Range("A1:B1").Interior.Color = vbYellow .Borders.Weight = xlThin .BorderAround Weight:=xlThick .Columns.AutoFit End With End With End If Next '----------------------------------------------------------------- With Sheets("التجميعى") ColFound = Application.Match("*مكتب التربية*", .Rows(1), 0) If IsNumeric(ColFound) Then .Range("G2:H2") = Array("الاحصاء النهائى لمكاتب التربية", "الجملة") Set Rng = .Range(.Cells(2, ColFound), .Cells(.Cells(Rows.Count, ColFound).End(xlUp).Row, ColFound)) Set Obj = CreateObject("scripting.dictionary") Data = Rng For P = 1 To UBound(Data) Obj(Data(P, 1) & "") = "" Next .Range("G3:G1000").ClearContents .Range("G3").Resize(Obj.Count, 1) = Application.Transpose(Obj.keys) '----------------------------------------------------------------- With .Range("H3:H" & .Cells(Rows.Count, "G").End(xlUp).Row) .Formula = "=SUMPRODUCT( (R2C2:R1000C2 =RC[-1]) * R2C3:R1000C3 )*2" .Value = .Value End With '----------------------------------------------------------------- With .Range("G2").CurrentRegion .Borders.Weight = xlThin .BorderAround Weight:=xlThick .Columns.AutoFit .Range("A1:B1").Interior.Color = vbYellow End With '----------------------------------------------------------------- .Columns("A:F").Delete Shift:=xlToLeft '----------------------------------------------------------------- End If End With '----------------------------------------------------------------- Sheets("Master").Activate Application.CutCopyMode = False Application.ScreenUpdating = True Application.DisplayAlerts = False End Sub أخى و أستاذى ياسر راجع هذا الكود و ان كان يحتاج لتحسينات فتفضل مشكورا تحياتى Collect Data From Multiple CSV Workbooks Yasser Mokhtar final.rar

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

أخى وأستاذى الغالى بارك الله فيك . اكتشفت خطأ فى المعادلة SUMPRODUCT و تم التصحيح أخى أبو يوسف المرفق التالى لحساب عدد التكرار لكل مكتب في جميع الاوراق هذا المرفق به كودين يتم استدعائهما بزر واحد اذا كنت تريد استدعاء كل كود على حده كما طلبت فى مشاركتك الأخيرة يمكنك التعديل بسهولة كالتالى السطر التالى فى الكود الاول يحذف Call CopyToNewSheet أضف شكلا تلقائيا أو زر و اربطه بالكود الثانى وأى ملاحظات أخرى فأهلا و سهلا بها فلا تخجل تحياتى لك ولأخى وأستاذى أبا البراء Collect Data From Multiple CSV Workbooks YasserKhalilMokhtar V 4.rar

أخي الحبيب الغالي مختار بارك الله فيك .. قمت بتعديل بسيط على كودك حيث حذفت الجزء الخاص بتنسيق النطاقات المنسوخة إذا لا داعي لها حيث أنك في نهاية المطاف تقوم بحذف الأعمدة إليكم المرفق الأخير حيث تم الجمع بين جميع الأكواد Collect Data From Multiple CSV Workbooks YasserKhalilMokhtar V3.rar

النتائج صحيحة بالفعل على ما يبدو لنا إليك الملف المرفق بدون حماية للتأكد ما هو الأوفيس الذي تستخدمه ؟ وما هي شكل النتائج لديك في الإحصاء؟ كوم.rar

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

السلام عليكم شاهد المرفق Book2_Arb.rar

مثال رقم 3 :- فى المثال رقم 2 كان الشرح على نفس الصوره السابقه فورم فى مرحلة التصميم وصممت عليه Frame والفريم لا يوجد به اى عناصر تحكم تم تصميمها وكان المثال برقم 2 انى اعمل كود عند فتح الفورم يكون هناك عدد 10 صفوف من العناصر كل صف به ليبل وتكست بوكس وكمبوبوكس المثال بتاعنا اليومعايز اعرف ازاى اضيف عناصر تحكم اثناء فتح الفورم من شيت اكسيل وعدد الصفوف بالشيت غير معروف عددها فى زياده او نقصان شاهد الصوره هتعرف اكتر المثال بتاعنا بكل بساطه نفس الكود اللى بالمثال 2 مع تعديلات فنيه بسيطه جدا دا كان الكود اللى بالمثال 2 Private Sub UserForm_Initialize() Dim Top As Integer Dim i As Integer Top = 5 For i = 1 To 10 With Me.Frame1.Controls.Add("Forms.Combobox.1", "Combobox" & i) .Left = 20 .Top = Top .Height = 40 .Width = 150 .BackColor = &HFFFFC0 .TextAlign = fmTextAlignCenter .FontSize = 20 .Font.Bold = True Dim a As Variant a = Array("ناجح", "راسب") .List = a End With With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Left = 180 .Top = Top .Height = 40 .Width = 150 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF End With With Me.Frame1.Controls.Add("Forms.Label.1", "Label" & i) .Left = 340 .Top = Top .Height = 40 .Width = 150 .SpecialEffect = fmSpecialEffectEtched .TextAlign = 2 .FontSize = 24 .Font.Bold = True .BackColor = 8454016 .Caption = "الصقر" & i End With Top = Top + 40 Next Me.Frame1.ScrollHeight = Top End Sub ايه المطلوب تعديله بالكود لكى يتناسب مع المطلوب بتاعنا رفع الخلايا من الشيت الى الفريم المثال كان على ان عدد الصفوف 10 لذالك استخدمنا الحلقه For next كالتالى For i = 1 To 10 فدلوقتى انا عايز اجيب الخلايا بالشيت رقم 1 النطاق من A2 الى اخر صف هيكون به اخر طالب اذن بداية الحلقه هى اول صف بالجدول وهو الخليه A2 ورقم الصف لها هو 2 اذن الحلقه هتبدأ من رقم 2 الى ؟ الى اخر صف به بيانات فى العمود A اذن لازم احدد اخر صف به بيانات من خلال السطر التالى واحنا شرحناه قبل كدا lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row عملت متغير واسمه Lr وتقدر تسميه اى اسم كيفما شئت وقلت ان المتغير Lr يساوى كتبت اسم الشيت المراد العمل عليه واستخدمت Cells لتحديد عدد الخلايا الممتلئه بالبيانات فى العمود 1 كدا انا عرفت الحلقه من اين تبدأ واين تنتهى ( تبدأ من الصف 2 الى اخر صف به بيانات ) For i = 2 To lr شاهد الكود بعد تعديل الحلقه For Private Sub UserForm_Initialize() Dim Top As Integer Dim i As Integer lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row Top = 5 For i = 2 To lr With Me.Frame1.Controls.Add("Forms.Combobox.1", "Combobox" & i) .Left = 20 .Top = Top .Height = 40 .Width = 150 .BackColor = &HFFFFC0 .TextAlign = fmTextAlignCenter .FontSize = 20 .Font.Bold = True Dim a As Variant a = Array("ناجح", "راسب") .List = a .Text = Sheet1.Cells(i, 3).Text End With With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Left = 180 .Top = Top .Height = 40 .Width = 150 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF .Text = Sheet1.Cells(i, 2).Text End With With Me.Frame1.Controls.Add("Forms.Label.1", "Label" & i) .Left = 340 .Top = Top .Height = 40 .Width = 150 .SpecialEffect = fmSpecialEffectEtched .TextAlign = 2 .FontSize = 24 .Font.Bold = True .BackColor = 8454016 .Caption = Sheet1.Cells(i, 1).Text End With Top = Top + 40 Next Me.Frame1.ScrollHeight = Top End Sub اللى مركز معايا هيلاقى 1- تم تعديل بداية ونهاية الحلقه For 2- فى سطر تم اضافته فى خصائص كل عنصر فى عنصر الكمبوبوكس تم اضافه السطر التالى .Text = Sheet1.Cells(i, 3).Text قيمة الكمبوبوكس هى كتبت اسم الشيت وهو بمثالنا الشيت 1 ثم الخلية المطلوبه Cells عباره عن (رقم العمود, رقم الصف)Cells ( Cells( i , 3 i هنا هى رقم الصف اللى هيتغير كل مره بالحلقه For والعمود هو رقم 3 الخاص بالحاله --------------------------------- فى عنصر التكست بوكستم اضافه السطر التالى .Text = Sheet1.Cells(i, 2).Text نفس الكمبوبوكس ولكن تم تغيير رقم العمود هو 2 الخاص بالدرجه ---------------------------------- فى عنصر الليبل تم اضافه السطر التالى .Caption = Sheet1.Cells(i, 1).Text نفس الكمبوبوكس والتكست بوكس ولكن تم تغيير رقم العمود هو 1 الخاص باسم الطالب ----------------------------------------------------------------------------------------------------------------------- ملحوظه اخيره لمن يريد درجة الاحترافيه فى الكود لما كنا بنعمل خصائص العنصر كان الخاصيه Left & Top & Width& Height لكل عنصر كان بيتم كتابتهم بالشكل التالى كلا منهم على حد فى سطر مختلف على سبيل المثال خصائص التكست بوكس With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Left = 180 .Top = Top .Height = 40 .Width = 150 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF .Text = Sheet1.Cells(i, 2).Text End With ممكن اكتب الاربع خصائص فى سطر واحد من خلال Move القاعدة الخاصه بــ Move Move Left, Top, Width, Height. ويكون شكل الكود كالتالى بالخصائص With Me.Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) .Move 180, Top, 150, 40 .TextAlign = 2 .FontSize = 20 .Font.Bold = True .BackColor = &HC0FFFF .Text = Sheet1.Cells(i, 2).Text End With تم استبدال الاربع صفوف بسطر واحد من خلال Move -------------------------------------------------------------------------------------------------------- جرب الكود بنفسك هتثبت المعلومه اكتر الى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد ان شاء الله هيكون عن كيفية التحكم فى العناصر الموجوده داخل الفريم سوء كانت مصممه اثناء عملية التصميم او تم انشائها بكود انتظرونا تقبلوا تحياتى

السلام عليكم ورحمة الله وبركاته ارجو المساعدة فى كود بحث فى الفورم بين تاريخين حسب التاريخ بالملف المرفق وشكلرا لسعة صدركم البحث بين تاريخين.rar

السلام عليكم ورحمة الله وبركاته إخوانى وأحبائى الأعزاء أعضاء وأساتذة عالم العلم والمعرفة بأوفيسينا تحية طيبة وبعد كنت قد طرحت موضوع من قبل عبارة عن Rank يسحب داتا معينة من Report وقام السيد الفاضل الأستاذ القدير / العيدروس بعمل لى كود أكثر من روعة وقمت بطرح هذا الكود للتعديل عليه مرة أخرى لسحبها بطريقة ما وتفضل أيضا أستاذى ومعلمى القدير / العيدروس بتعديلة اليوم أطرح نفس الكود لتعديل جزء بسيط به خاص بخانة معينة داخل Rank مظللة باللون الأصفر لتعطى النتيجة الموضحة داخل اللون الأصفر وهى عبارة عن جميع الأصناف المباعة للمندوب حتى لو مكررة أى كاملة مرفق الملف وبه الكود وأيضا الكود موضح الرجاء المساعدة ولسيادتكم خالص الشكر والتقدير مع وافر التحية Private Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean) Dim Shet As Worksheet Dim Do_Ali Dim Ar() As Variant Dim iCnt& Dim X, A On Error Resume Next Set Shet = Sheets("Report") Set Do_Ali = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False .EnableEvents = True DoEvents With Shet Lr = .Cells(.Rows.Count, 2).End(xlUp).Row Ar = .Range("A2:F" & Lr).Value: A = Bl For R = LBound(Ar, 1) To UBound(Ar, 1) If Ar(R, 3) = A Then If Not Bln Then If Vl = 3 Then ZZ = Ar(R, 2): ZZZ = Ar(R - 1, 2) If ZZZ <> ZZ Then X = X + 1 End If End If If Vl = 4 Then X = X + Ar(R, 6) End If End If If Do_Ali.exists(Ar(R, Ln)) Then Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1 Else Do_Ali.Add Ar(R, Ln), 1 End If End If Next Ali = IIf(Vl = 1, Do_Ali.Count, X) End With .ScreenUpdating = True .EnableEvents = False End With Erase Ar Set Do_Ali = Nothing Set Shet = Nothing End Function Sub Ali_Count() Dim Sh As Worksheet Dim Sht As Worksheet Dim R, Rr, Cll, Lrr Set Sh = Sheets("Rank") Set Sht = Sheets("Report") With Sh Lrr = Sht.Cells(Rows.Count, 2).End(xlUp).Row Sht.Sort.SortFields.Add Key:=Sht.Range("A2:A" & Lrr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sht.Sort .SetRange Sht.Range("A1:F" & Lrr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rr = 10: Cll = 13 For R = Rr To Cll If .Cells(R, 2) <> "" Then .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False) .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False) .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True) .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True) End If Next End With MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna " End Sub Rank End.rar

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

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

أخي الغالي مختار يوجد بالفعل خطأ في أثناء تنفيذ الكود مع الملفات التي بها صفين فقط من البيانات فقمت بتعديل الكود بحيث يزود كمان صف على الموجود كما قمت بإدراج الإحصاء في العمودين Y و Z بدلاً من العمودين M و N لأنني لاحظت أن بعض الملفات بها بيانات في هذين العمودين للأسف وأكرر للأسف تحدث مشاكل حين يكون المرفق غير معبر عن الملفات الأصلية .. لأننا اشتغلنا على مجموعة ملفات لها نفس المواصفات أما عند إرفاق ملفات جديدة لها مواصفات جديدة فكان لابد من التغيير ليتلائم الكود مع الوضع القائم عموماً إليك المرفق التالي فيه المصنف الرئيسي ومرفق ملفات CSV الأخير المسمى girl (قم بتغيير اسمه ..ولن يؤثر في شيء) Collect Data From Multiple CSV Workbooks Mokhtar YasserKhalil V4.rar

السّلام عليكم و رحمة الله و بركاته أخي الكريم " محمّد عبد السّلام " .. قمت بعمل ملفين للشّريط المتحرّك بملفين مختلفيْن .. قمْ باختيار اللّون الذي يناسب ذوقك .. و إذا كان الاتّجاه خاطئًا و ليس الذي تريده .. أخبرني لتغييره فائق إحتراماتي fatorrr.rar

ياعم ناصر التنسيقات شغاله زي الفل انا عملت زر فقط لعمل التنسيقات علي جميع الورق هي بتطبق التنسيقات عل جميع الشيتات بناء علي الورقة 2 فالكود دا هيفرق مع الشيت الاخير بس لانه مش نفس تقسيمة الشيتات كلها نحاول نعمله تظبيطه لوحده بس جرب كدا الاول ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة +7777.rar اخي الغالي ابو البراء انا معايا الكتالوج بتاع ناصر لو تحب تطلع عليه انا بفهم ناصر من غير ما يقول حاجه يحط المرفق وانا اشتغله فيه علي طول

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

Sub MakeFolders() Dim Rng As Range Dim maxRows, maxCols, r, c As Integer Dim Pth As String Set Rng = Selection maxRows = Rng.Rows.Count maxCols = Rng.Columns.Count Pth = "C:\Users\abdu\Desktop\" '' تحط مسار حفظ المجلدات هنا For c = 1 To maxCols r = 1 On Error Resume Next Do While r <= maxRows If Len(Dir(Pth & Rng(r, c), vbDirectory)) = 0 Then MkDir (Pth & Rng(r, c)) End If r = r + 1 Loop Next c On Error GoTo 0 End Sub هكذا لتحديد مسار Sub MakeFolders() Dim Rng As Range Dim maxRows, maxCols, r, c As Integer Dim Ali_F As Object Dim Pth As String Set Rng = Selection maxRows = Rng.Rows.Count maxCols = Rng.Columns.Count Pth = "C:\Users\abdu\Desktop\" '' تحط مسار حفظ المجلدات هنا For c = 1 To maxCols r = 1 On Error Resume Next Do While r <= maxRows Set Ali_F = CreateObject("Scripting.FileSystemObject") If Not Ali_F.FolderExists(Pth & Rng(r, c)) Then Ali_F.CreateFolder (Pth & Rng(r, c)) End If r = r + 1 Loop Next c On Error GoTo 0 Set Ali_F = Nothing End Sub واذا لم تعمل معك اداة MkDir جرب هذا الكود بطريقة اخرى

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

بارك الله فيك اخي الغالي وزاده في ميزان حسناتك اللهم تغمد فقيدنا الحسامي بواسع رحمتك ورزقك اخ الغالي ورزقنا العلم والعمل الصالح

حبيبى الغالى زيزو دائما سباق بالخيرات شاكر مرورك العطر يا غالى تقبل تحياتى

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

استبدل الكود عندك بها الكود وسوف ترى النتيجة Sub زر_1() lh = Cells(Rows.Count, "H").End(3).Row lc = Cells(Rows.Count, "c").End(3).Row Range("H5:H" & lh).Clear Range("c5:c" & lc).SpecialCells(xlCellTypeConstants, 1).Copy Range("H5") End Sub

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

السّلام عليكم و رحمة الله و بركاته أسأل الله العلي القدير أن يسهّل أمورك و يوفّقك لما يحبّه و يرضاه نحن ننتظر أعمالك بفارغ الصّبر فائق إحتراماتي

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

معلش يابو البراء ياغالي ناصر دا ياما شخط فيه عشان يعقل بس دا ميمنعشي انه ابن حلال مصفي ربنا يوفقه في موضوعه اللي له بداية ونهايته غير معلومة ايه ياعم ناصر متركز يامعلم قبل ما تمسك الماوس برطمان قهوة وكوز شاي ودوس وربنا يقدرنا علي فعل الخير

الله ينور ربنا يفتح عليك اكتر واكتر ههههههههه المشكلة كانت ان الشيت فيه تقريبا 500 ورقه كان لازم يطبعها من الاخر للاول عشان مش كل لما ورقة تطلع اقلبها على ضهرها وممكن انسى ورقه مكان التانية عشان لازم يبقى المستخلص مترتب بس تماااااااااااااااام اوى المشكلة اتحلت خلاص الف الف الف مليون شكر ليك

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

اخى حسين تم رفعه على درايف لان المساحه غير مقبوله كتاب شرح تثبيت sql server 2008 خطوة خطوة (شرح مفصل بالصور) بالتوفيق

بعد اذن الاستاذ محمد سلامه لي سؤال كيفية تنصيب sql server 2008 ويندوز 7 بايت 32 وما المطلوب عمله قبل التنصيب وهل يلزم عمل مستخدمين علي الويندوز لو امكن شرح وافي لوتكرمتم

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

السلام عليكم ======================= تم إضافة عمود لحالة الأقساط للعملاء ======================= وزر لطباعة التقرير في فورمة التقرير الكلي ======================= المرفق الاولى شرح طريقة العمل مع الاضافة والمرفق الاخر الملف تحياتي شرح_1.rar الاقساط_Ali_12.rar

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

السلام عليكم ورحمة الله وبركاته تحياتى وتقديرى لجميع أحبائى أعضاء وأساتذة هذا الصرح العلمى الهائل أدخل المعادلة الأتية بأى خلية داخل الإكسيل وشاهد النتيجة بنفسك تحياتى =CHAR(225)&CHAR(199)&CHAR(32)&CHAR(197)&CHAR(225)&CHAR(229)&CHAR(32)&CHAR(197)&CHAR(225)&CHAR(199)&CHAR(32)&CHAR(199)&CHAR(225)&CHAR(225)&CHAR(229)&CHAR(32)&CHAR(227)&CHAR(205)&CHAR(227)&CHAR(207)&CHAR(32)&CHAR(209)&CHAR(211)&CHAR(230)&CHAR(225)&CHAR(32)&CHAR(199)&CHAR(225)&CHAR(225)&CHAR(229)

اهداء مصطفى كمال معلم اول مدرسة امل الزقازيق رابط تدريبات الرضيات للصم http://gulf-up.com/do.php?id=27682 رابط تدريبات اللغة الانجليزية للصم http://gulf-up.com/do.php?id=27686 رابط تدريبات اللغة العربية للصم http://gulf-up.com/do.php?id=27691

وعليكم السلام . تفضل ، المرفق في هذا الرابط يقوم بفتح النموذج عدة مرات ، بدون ان يعمل نسخ جديدة: http://allenbrowne.com/ser-35.html جعفر

ان شاء الله ما فيش تقصير كل ما هنالك مشاغل الحياة تطغى علينا المرفق التالى تم فيه جمع البيانات من المجلد كما تم حساب عدد تكرار كل مكتب تربية وتعليم بالمعادلات شوف الخطوة اللى جايه ايه Collect Data From Multiple CSV Workbooks Mokhtar V2.rar

أشكرك أخى و أستاذى الكبير ياسر خليل مشكور على التعديل اللى ما جاش على بالى ده

Sub CollectDataFromMultipleWorkbooks() Dim OpenFiles Dim crntfile As Workbook Set crntfile = Application.ActiveWorkbook Dim X As Integer Dim SH As Worksheet Dim Arr, Temp, I As Long, J As Long On Error GoTo ErrHandler Application.ScreenUpdating = False OpenFiles = Application.GetOpenFilename(FileFilter:="Microsoft Excel Files (*.csv;*.xlsx;.xlsm),*.csv;*.xlsx;*.xlsm", MultiSelect:=True, Title:="Select Excel File To Merge!") If TypeName(OpenFiles) = "Boolean" Then MsgBox "You Need To Select At Least One File" GoTo ExitHandler End If X = 1 While X <= UBound(OpenFiles) Workbooks.Open Filename:=OpenFiles(X) Sheets().Move After:=crntfile.Sheets(crntfile.Sheets.Count) X = X + 1 Wend Sheets("Master").Activate For Each SH In ThisWorkbook.Sheets With SH If .Name <> "Master" Then Arr = .Range("A1").CurrentRegion.Value For I = 1 To UBound(Arr) Temp = Split(Arr(I, 1), ";") For J = 1 To UBound(Temp) .Cells(I, J) = Temp(J) Next J Next I .Range("A1").CurrentRegion.Columns.EntireColumn.AutoFit End If End With Next SH ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub أخي الحبيب مختار بارك الله فيك على الكود الرائع الذي قدمته لنا على طبق من ذهب أخي الكريم صاحب الموضوع ..يرجى تغيير اسم الظهور للغة العربية (راجع التوجيهات في الموضوعات المثبتة في المنتدى) جرب الملف التالي بعد إضافة بسيطة لكود الأخ المتميز مختار ليقوم بفصل العمود الواحد لعدة أعمدة تقبل تحياتي Collect Data From Multiple CSV Workbooks Mokhtar V1.rar

متأسف لم أشاهد مشاركتك الا بعد أن عدلت فى مشاركتى ملحوظة للحصول على نتائج جيدة اجعل كل الملفات بصيغة xlsx بلاش من csv الخطوة اللى جاية باذن الله سهلة وهى حساب عدد تكرار كل مكتب تربية وتعليم بعد أن تقرر : هل النتائج مرضية بعد تحويل كل ملفاتك الى صيغة xlsx أم لا ؟

وبما ان الاستعلام الذي استعملته هنا هو استعلام جدولي ، فاليك نصيحة كلفتني غاليا حتى عرفتها: http://www.officena.net/ib/topic/61853-فلتر-التاريخ-نصف-سنوى/?do=findComment&comment=401042 جعفر

السلام عليكم ورحمة الله بعد إذن اخي الأستاذ ياسر العربي هذا شرح طريقة تلوين صف بناء علي قيمة خلية بملف Word مع ملف إكسل كمثال مصغر علي الرابط التالي : http://www.officena.net/ib/topic/65012-كيفية-تلوين-صف-بناء-علي-قيمة-خلية-مع-مثال-مصغر/

جرب هذا الملف القائمة المنسدلةتستجيب لاي تعديل او زيادة في البيانات قائمه منسدله مطاطة.zip

Private Sub Worksheet_Change(ByVal Target As Range) If Me.[T1] Then Exit Sub If Not Application.Intersect(Target, Range("Yasser")) Is Nothing Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "It is not your right to make any adjustment without reference to the Engineer / Yasser Fathi Al-Banna " End If End Sub السلام عليكم أخى الكريم هل تريد مثل المرفق ضع هذا الكود فى حدث الشيت ثم إتبع الخطوات التالية إفتح قائمة formulas ثم Name Manager ثم إختار New Name وأكتب فى الخانة Name وليكن إسم اخوك كما بالكود Yasser ثم أمام الخانة Refers To حدد الخلايا المراد حمايتها ثم إضغط OK ثم Close وجرب Book1.rar

جرب هذا لكود (انه يقوم بطباعة كل 25 سطر على صفحة واحدة مع العنوان الرئيسي) يمكنك تغيير العدد 25 من خلا ل الكود بتغيير مقدار العامل deg في السطر رقم 10 للمزيد انظر الى المرفق Sub my_setup() Application.ScreenUpdating = False k = 0 ActiveSheet.PageSetup.PrintArea = "" lr1 = Cells(Rows.Count, 1).End(3).Row On Error Resume Next ActiveSheet.PageSetup.PrintTitleRows = "$1:$1" Range("a1:a" & lr1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete deg = 25 'you can change this number lr = Cells(Rows.Count, 1).End(3).Row For i = 0 To lr Step deg If lr - i < deg Then Exit For ActiveWindow.View = xlPageBreakPreview Set ActiveSheet.HPageBreaks(k + 1).Location = Range("A" & i + deg + 2) k = k + 1 Next m = "$A$1:$E$" & lr1 & """" ActiveSheet.PageSetup.PrintArea = m ActiveSheet.DisplayPageBreaks = False ActiveWindow.View = xlNormalView Application.ScreenUpdating = True End Sub My_print_Set_Up.zip

السلام عليكم _____.rar

السلام عليكم تفضل المرفق معمول بالمعادلات ____________.rar

السلام عليكم ارجو ان ينال اعجابكم خالص تحياتي Add_sheet_with_name_with_hyper.rar

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