شوقي ربيع

جرب هذا الكود للتعديل لاكن ممكن يكون ثقيل في حالة كثرة البيانات Dim iRow As Long: iRow = Me.TextBox6.Value + 2 Dim ws As Worksheet Dim sName As String: sName = Me.ComboBox2.Value Set ws = ThisWorkbook.Sheets(sName) Dim lLrw As Long, lRw As Long: lRw = 3 Dim ii As Long: ii = Me.TextBox6.Value Dim rRng As Range With ws lLrw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 For Each rRng In ws.Range("A3:A" & lLrw) If ii = rRng.Value Then .Cells(lRw, 1).Value = TextBox6.Value .Cells(lRw, 2).Value = TextBox7.Value .Cells(lRw, 3).Value = TextBox8.Value .Cells(lRw, 4).Value = TextBox9.Value Exit For End If lRw = lRw + 1 Next End With

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

كود التعديل شغال ربما انت تنفذ على ملف اخر لذى يجب ان تفهم اني اعتمدت في كود التعديل على رقم الطالب كما تلاحظ هنا Dim iRow As Long: iRow = Me.TextBox6.Value + 2 بعتبار ان المتغير iRow هو سطر التعديل انا اضفت له رقم 2 ليتناسب مع السطر الفعلي الذي يحتوى البيانات لان السطر الذي تبدء منه البانات هو السطر الثالث في الشيت انت عدل حسب السطر الذي تبدا منه البيانات في الملف لديك مثلا لو البايانات تبدء من السر الرابع اضف 3 وهكذا

السلام عليكم الشكر موصول للاخ طلعت هذا حل بواسطة المصفوفات فهي اسريعة ودقيقة كود البحث وفي نفس الوقت يجمع عمود الاسعار For i = LBound(keyArray) To UBound(keyArray) bMonth = Month(keyArray(i, 1)) If keyArray(i, 4) = d And bMonth = ComboBox1.ListIndex + 1 Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 4) itemArray(3, e) = keyArray(i, 5) itemArray(4, e) = keyArray(i, 7) x = x + Val(keyArray(i, 7)) End If Next i If e > 0 Then If UBound(itemArray, 2) > 1 Then Me.ListBox1.List = Application.Transpose(itemArray) Else Dim c(1 To 1, 1 To 4) c(1, 1) = itemArray(1, 1) c(1, 2) = itemArray(2, 1) c(1, 3) = itemArray(3, 1) c(1, 4) = itemArray(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If تحياتي للجميع تقارير شهرية.rar

السلام عليكم لتعبئة الكبوبوكس باسماء الشيتات الموجودة في الملف Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets Me.ComboBox1.AddItem ws.Name Me.ComboBox2.AddItem ws.Name Next لتسجيل بيانات جديدة على حسب الشيت المختار من الكمبوبوكس Dim ws As Worksheet If Me.ComboBox1 = "" Then Exit Sub Dim sName As String: sName = Me.ComboBox1.Value Set ws = ThisWorkbook.Sheets(sName) Dim iRow As Long: iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 Dim i As Byte If Trim(Me.TextBox1.Value) = "" Then Me.TextBox1.SetFocus MsgBox "ÑÌÇÁ ÇãáÇÁ ßá ÇáÎÇäÇÊ ÇáÎÇÕÉ ÈÈíÇäÇÊ ÇáãæÙÝ", vbOKOnly, "ÊÓÌíá ãæÙÝ" Exit Sub End If For i = 1 To 4 ws.Cells(iRow, i).Value = Me("TextBox" & i).Value Me("TextBox" & i).Value = "" Next كود البحث عبر لقب الطالب d = UCase(Me.TextBox5) & "*" e = 0 On Error GoTo Err 1 For i = LBound(keyArray) To UBound(keyArray) If UCase(keyArray(i, 2)) Like d Then e = e + 1: ReDim Preserve itemArray(1 To 4, 1 To e) itemArray(1, e) = keyArray(i, 1) itemArray(2, e) = keyArray(i, 2) itemArray(3, e) = keyArray(i, 3) itemArray(4, e) = keyArray(i, 4) End If Next i If e > 0 Then If UBound(itemArray, 2) > 1 Then Me.ListBox1.List = Application.Transpose(itemArray) Else Dim c(1 To 1, 1 To 4) c(1, 1) = itemArray(1, 1) c(1, 2) = itemArray(2, 1) c(1, 3) = itemArray(3, 1) c(1, 4) = itemArray(4, 1) Me.ListBox1.List = c End If Else Me.ListBox1.Clear End If Exit Sub Err: Dim ws As Worksheet Dim sName As String: sName = Me.ComboBox2.Value Set ws = ThisWorkbook.Sheets(sName) Dim iRow As Long: iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 keyArray = ws.Range("A3:B" & lrw).Value GoTo 1 كود التعديل على البايانات Dim iRow As Long: iRow = Me.TextBox6.Value + 2 Dim ws As Worksheet Dim sName As String: sName = Me.ComboBox2.Value Set ws = ThisWorkbook.Sheets(sName) ws.Cells(iRow, 1).Value = TextBox6.Value ws.Cells(iRow, 2).Value = TextBox7.Value ws.Cells(iRow, 3).Value = TextBox8.Value ws.Cells(iRow, 4).Value = TextBox9.Value تحياتي للجميع كتابة قوائم الطلبة من خلال فورم واحد.rar

السلام عليكم اخي ياسر جزاك الله خيرا على هذا الكود الف مبروك القنات وان شاء الله تكون منبر من منابر تعلم الاكسل متخفش اخوك شوقي موجود جنبك يصرف معاك 1000 عفريت هذه محاولة مني كبداية لجمع اول شيت من عدت ملفات اكسل من اي مجلد من على الجهاز في ملف اكسل واحد بحيث تكون اسماء الشيتات على اسماء تلك الملفات المجمعة الاندماج بعد الانشطار الكود مقسم الى قسمين القسم الاول يقوم بفتح نافذة لاختيار مجلد من الجهاز Function ChoixDossier() If Val(Application.Version) >= 10 Then With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ActiveWorkbook.Path & "\" .Show If .SelectedItems.Count > 0 Then ChoixDossier = .SelectedItems(1) Else ChoixDossier = "" End If End With Else ChoixDossier = InputBox("Répertoire?") End If End Function القسم الثاني وهو قسم الدمج فكرته بسيطة وهي عبارة عن حلقة دوارانية تبحث في المجلد المختار عن ملفات الاكسل ثم تفتح الملفات واحد تلو الاخر مع نسخ محتوى الشيت الاول لكل ملف ثم لصق ما تم نسخه في شيت جديد في الملف الرئيسي مع اعطاء اسم الملف الى ذلك الشيت الجديد هذا كل ما في الامر Sub Affiche() Dim wb1 As Workbook, wb2 As Workbook Dim sPaNam As String Set wb1 = ActiveWorkbook Application.ScreenUpdating = False Application.DisplayAlerts = False For Each F In dossier.Files If UCase(Right(F.Name, 4)) = "XLSM" Then If UCase(Left(F.Name, 2)) <> "~$" And F.Name <> ThisWorkbook.Name Then sPaNam = xPath & "\" & F.Name Dim bT As Byte: bT = InStr(F.Name, ".xlsm") - 1 Dim sName As String: sName = Left(F.Name, bT) Set wb2 = Workbooks.Open(sPaNam) wb2.Sheets(1).Copy Before:=wb1.Sheets(1) ActiveSheet.Name = sName wb2.Close SaveChanges:=False Set wb2 = Nothing End If: End If Next Set wb1 = Nothing Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub اما هذا الكود Sub Agrégation() xPath = ChoixDossier() If xPath = "" Then Exit Sub Set Fs = CreateObject("Scripting.FileSystemObject") Set dossier = Fs.getfolder(xPath) Affiche End Sub يقوم باستدعاء الكودين الاولين حيث في الاول نمسك بمسار المجلد المختار ثم قمنا بتعريف المتغير Fs على انه ملف اما المتغير dossier تم تعريفه على انه مجلد تحياتي للجميع الملف الرئيسي الذي يحوي الاكواد هو الملف المسمى ب compilation de fichier Plusieurs fichiers en une seule compilation de fichier.rar

السلام عليكم حاولة ان افهم الفكرة لاكني للاسف لم استوعبها ممكن تشرحها اكثر او ترفق ملف اكثر توضيح من الملف الاول

ارجو التوضيح اكثر لاني بصراحة لم استوعب الامر ومخي اليوم شويا ملبد

اختر افضل اجابة ليكون الموضوع مجاب واايد اخي ياسر في تغير عنوان الموضوع ليعبر عن مضمونه ليسهل البحث في المستقبل

جزاكم الله خيرا وشكرا جزيلا لمروركم بالموضوع تحياتي وتقديري للجميع

اختر افضل اجابة ليظهر الموضوع مجاب

السلام عليكم من خيرات المطور اختر وضع التصميم احذف الكمبوبوكس واليست بوكس الموجودين في الشيت وادرج غيرهما من عندك مع مراعات ان اسم الكمبوبكس يكون ComboBox1 واليست بوكس يكون ListBox1 جرب واعلمني تحياتي

السلام عليكم شكرا جزيلا لمرورك العطر ولعبارتكم الجميلة كل بأسمه جزاكم الله خيرا

تم الحل لاكن النتائج تكون قيم وليست معادلة كما كانت سابقا تم تصحيح الامر سؤال هل محتوى الصفحات المنسوخة ثابة يعني لما تضغط F2 وتنشئ التذيل ثم تظغط اوك لانشاء الجدول ,الجدول الجديد يحمل نفس النتائج السابقة هل تغيرها يدويا ام تبقى ثابة التعديل المطلوب.xlsb.rar

بسم الله الرحمان الرحيم السلام عليكم هذا الموقع عبارة عن برنامج متكامل يمكنك من خلاله تتبع وتسيير امورك المحاسبية وفيه العديد من الميزات فقط سجل فيه وله عدت واجهات منها العربية سهل الاستخدام طريقة متكاملة لإدارة الفواتير أنشئ فواتير مهنية و أنيقة تتبع الوضع الحالي للفواتير https://aliphia.com/ تحياتي للجميع

الطلب مكرر تم الحل في المشاركة http://www.officena.net/ib/index.php?showtopic=59725

السلام عليكم Dim ws As Worksheet Dim sPath As String متغيرين لاول لتحديد الشيت الذي سنعمل عليه الثاني من اجل مسار الملف الخاص بنا وكوده يكون sPath = ThisWorkbook.Path & "\Image\" اما هذا الكود لتعبئة الكمبوبوكس ذات عمودين من شيت الداتا With Me.ComboBox1 .List = ws.Range("A2:B11").Value .ColumnCount = 2 End With هذا الكود لعرض الصورة في الفورم على حسب ما نختاره من كمبوبوكس On Error GoTo ErrHandler: Me.Image1.Picture = LoadPicture(sPath & Me.ComboBox1.Text & ".jpg") Exit Sub ErrHandler: Me.Image1.Picture = LoadPicture(sPath & "AucuneImage.jpg") Resume Next هذا السطر On Error GoTo ErrHandler معناه عندما يكون هناك خطاء ينتقل تنفيذ الكود الى ErrHandler وفائدته هي انه عندما لا تكون هناك صورة في ملف الصور تحمل رقم الموضف الفيوجل يعطي خطاء لذا نتخطاه بالكود السابق لاكن مع تنفيذ اجراء وهو الاجراء المتمثل في الجزء Me.Image1.Picture = LoadPicture(sPath & "AucuneImage.jpg") حيث AucuneImage هو اسم صورة محفوضة مسبقا في ملف الصورة تدل على عدم وجود صورة لذلك الموضف هذا الكود المستعمل لفتح نافذت الملفات لنختار منها الصورة مع شرط اضهار الصور فقط ذات الامتدادات gif jpg jpeg وهي الامتدادات التي تتوافق مع الفيوجل وهو الذي تبحث عنه Dim sFilter As String Dim vaFile As Variant sFilter = "Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp," & _ "Old Files (*Old) ,*.old," & _ "All Files (*.*) ,*.*" vaFile = Application.GetOpenFilename(FileFilter:=sFilter, _ FilterIndex:=1, _ Title:="ÇÎÊÑ ÕæÑÉ", _ MultiSelect:=False) If vaFile <> False Then Me.Image1.Picture = LoadPicture(vaFile) End If الاسطر If vaFile <> False Then Me.Image1.Picture = LoadPicture(vaFile) End If من الكود السابق معناها هو انه عندما المستعمل يختار صورة يتم عرضها في الفورم لحفظ الصورة المحملة على الفورم في المجلد الخاص بالصور برقم الموضف لدينا استخدمنا الكود SavePicture Me.Image1.Picture, sPath & Me.ComboBox1.Text & ".jpg" اما للحذف استخدمنا Me.Image1.Picture = LoadPicture(sPath & "AucuneImage.jpg") في حقيقة الامر لا يتم حذف الصورة بل يتم استبدالها بالصورة التي تكلمنا عنها في الاول التي تعني لا يوجد صورة فلهذا الموضف لاتنسى فك الضغط عن ملف الاكسل و ملف الصور ووضعهما في مكان واحد ليشتغل الكود ولا يعطي خطاء تحياتي للجميع FrmImageTaste.rar

غالي والطلب رخيس من عنيا الاثنين فقط يتاح لي بعض الوقت وساعمل على الموضوع تحياتي

السلام عليكم شاهد هذا الموضوع http://www.officena.net/ib/index.php?showtopic=56519&hl= المشاركة رقم ثمانية هو نفس طلبك حاول التطبيق بنفسك وان لم تصتطع سنشرح لك الامر وان لم تستطع سنقدم لك الحل على مرفقك تحياتي

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

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

السلام عليكم اخي وصديقي ضاحي الغريب الغائب عن المنتدى الحاضر في قلوبنا لا اجد ان اقول لك اكثر من قول اخي ياسر امين يارب العالمين

السلام عليكم احسنت السؤال اخي الصقر ما قلته اخي الصقر صحيح و لاكن ؟؟؟؟ بحسب الطريقة التي ذكرتها الكبو تتنبئ بالاصناف لاكن هته الطريقة تجلب لك اسم واحد فقط وليس كما هو الحال مع الملف الذي ارفقته فما فعلته عبارة عن فلترة محتوى الكمبوبوكس وهو ما يسمى بالنص التنبئ كما هو الحال عندما تقوم بالبحث عبر محرك البحث قوقل يجلب لك اقرب الكلمات تبعا للحروف التي تكتبها اما المتغير a ليس متغير عادي فهو مصفوفة وقد عرفته على كامل الفورم لانه الاساس فس عملية البحث شكرا على سؤالك القيم واي استفسارات اخرى لا تتردد تحياتي للجميع

عذرا مشاركة مكررة تم مسحها

اخي ابو ليله On Error Resume Next عند استخدامه فأنت تقول للفيوجال ابتداءا من هذا السطر وعندما يقابلك اي خطاء تخطاه وانتقل لسطر الذي بعده وشخطيا لا احبذ استخدامه الا لضرورة القصوى الخطاء في الملف كان كا الاتي اولا نشرح الكود المستعمل لكي تفهم الامر الكود ببساطة يعتمد على المصفوفات كما تلاحظ المصفزفة Ary هي مصفوفة الرئيسية التي خزنا فيها كامل بيانات الداتا Ary = ws.Range("A2:D" & lrw).Value ثم انشئة مصفوفة اخرى Aryy من اجل البحث عن القيم من المصفوفة الاولة و تخزين النتائج المطابقة لشرط البحث فيها For i = LBound(Ary) To UBound(Ary) If UCase(Ary(i, 1)) Like d Then e = e + 1: ReDim Preserve Aryy(1 To 3, 1 To e) Aryy(1, e) = Ary(i, 1) Aryy(2, e) = Ary(i, 2) Aryy(3, e) = Ary(i, 3) End If Next i حيث LBound(Ary) هو الحد الاول للمصفوفة UBound(Ary) الحد الاخير للمصفوفة If UCase(Ary(i, 1)) Like d Then هو شرط البحث حيث d = UCase(Me.ComboBox1) & "*" اي ما يكتب داخل الكمبوبوكس واستعملنا هذا السطر ReDim Preserve Aryy(1 To 3, 1 To e) لتغيير حجم المصفوفة الثانية دون فقدان البيانات التي تحويها لاننا نعتمد على الحلقات التكرارية في البحث فكما تلاحظ كل ما يتحقق الشرط نملئ المصفوفة الثانية بالبيانات التي حققت الشرط وذالك في الاسطر Aryy(1, e) = Ary(i, 1) Aryy(2, e) = Ary(i, 2) Aryy(3, e) = Ary(i, 3) كل سطر يملئ احد اعمدة المصفوفة علما من انا مصفوفتنا مكونة من ثلاثة اعمدة اما المتغير e ما فائدتة ؟ فائدته هي معرفة عدد اسطر المسفوفة الثانية فعند اكتمال دورة الحلة التكرارية والخروج منها المتغير e ينبانا بعدد الاسطر التي خزنت في المصفوفة الثانية وما فائدت هذا الكلام ؟ فائدته هي حسب الكود التالي If e > 0 Then If UBound(Aryy, 2) > 1 Then Me.ComboBox1.List = Application.Transpose(Aryy) Else Dim c(1 To 1, 1 To 3) c(1, 1) = Aryy(1, 1) c(1, 2) = Aryy(2, 1) c(1, 3) = Aryy(3, 1) Me.ComboBox1.List = c End If Me.ComboBox1.DropDown End If If e > 0 Then يعندي ان عدد اسطر المسفوفة الثانية ميسويش الصفر بعده ادرجنا السطر الثاني If UBound(Aryy, 2) > 1 Then وهو ايضا عبارة عن شرط ومعناه انه ادذا كان عدد اسطر المصفوفة الثانية اكثر من سطر ف Me.ComboBox1.List = Application.Transpose(Aryy) اي عبئ لنا مباشرتا محتوى المصفوفة الثانية في الكمبوبوكس الخاصتنا مع استخدامنا لدالة Transpose لقلب نطاق اعمدة المصفوى الى افقى بدل مما هي عليه عمودية وهذه النتيجة تكون عندما يكون لدينا اكثر من صنف لهم نفس اول الاحرف اما اذا كان عدد اسطر المصفوفة الثانية يساوي الواحد مالذي سيحدث ؟ سيكون لدينا نتيجة واحدة وهي الصنف ثم الكية ثو السعر حتى مع استخدام Transpose ستكون النتيجة في الكمبوبوكس ماسبق ذكره لاكن تحت بعضهم البعض في القائمة المنسدلة اذا استعنا بمصفوفة ثالثة اسميناها c لاكنها ليست كا لمصفوفتين السابقتين السابقتين هما مصفوفتان ديناميكية اما الاخيرة فهي مصفوفة ثابتة الحجم حيث تحوي على عمود واحد و ثلاثة اسطر كما هو في تعريفها دا خل الكود Dim c(1 To 1, 1 To 3) ثما قمنا بتعبئة المصفوفة الثالثة بالبيانات التي حصلنا عليها في المصفوفة الثانية (ولا تنسى انها تحوي على سطر واحد في هذه الحالة) c(1, 1) = Aryy(1, 1) c(1, 2) = Aryy(2, 1) c(1, 3) = Aryy(3, 1) ثم قمنا بنقل محتوى المصفوفة الثالثة الى الكمبوبوكس . . . . اذا بعد شرح الكود اين الخطاء الذي كان من قبل في الملف الاول لو تلاحظ في الملف الاول ان الكود الخاص ب الحالة الاخيرة اي عندما تكون النتيجة سطر واحد كان هكذا Dim c(1 To 1, 1 To 2) c(1, 1) = Aryy(1, 1) c(1, 2) = Aryy(2, 1) c(1, 3) = Aryy(3, 1) وهذا خطاء لاننا نحاول تعباة مصفوفة ذات سطرين بثلاثة اسطر وهو الخطاء الذي كان في الملف حيث اني عرفت المصفوفة الاخيرة الثابتة الحجم ابانها تحوي سطرين Dim c(1 To 1, 1 To 2) بدل ثلاثة اسطر Dim c(1 To 1, 1 To 3) . . . . (ماذ لو اردنا التطور اكثر فاكثر) الامر ابسط مما تتصور فقط نزيد في ابعاد المصفوفات المستعملة في الكود هذا مثال ل سبعة اعمدة For i = LBound(Ary) To UBound(Ary) If UCase(Ary(i, 1)) Like d Then e = e + 1: ReDim Preserve Aryy(1 To 7, 1 To e) Aryy(1, e) = Ary(i, 1) Aryy(2, e) = Ary(i, 2) Aryy(3, e) = Ary(i, 3) Aryy(4, e) = Ary(i, 4) Aryy(5, e) = Ary(i, 5) Aryy(6, e) = Ary(i, 6) Aryy(7, e) = Ary(i, 7) End If Next i If e > 0 Then If UBound(Aryy, 2) > 1 Then Me.ComboBox1.List = Aryy 'Application.Transpose(Aryy) Else Dim c(1 To 1, 1 To 7) c(1, 1) = Aryy(1, 1) c(1, 2) = Aryy(2, 1) c(1, 3) = Aryy(3, 1) c(1, 4) = Aryy(4, 1) c(1, 5) = Aryy(5, 1) c(1, 6) = Aryy(6, 1) c(1, 7) = Aryy(7, 1) Me.ComboBox1.List = c End If Me.ComboBox1.DropDown End If Else في الاخير ارجو ان يكون الشرح مفهوم واي استفسارات اخرى لاتتردد في السؤال تحياتي لجميع