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

يمكنك استعمال هذا الكود وتنفيذه في شيت الترحيل وليس في sheet1 Sub mas_taqseem() Application.ScreenUpdating = False lr = Sheet1.Cells(10000, 1).End(xlUp).Row Range("A2:K100").ClearContents col = 1 For i = 2 To lr Step WorksheetFunction.Ceiling((lr - 1) / 3, 1) For j = 2 To WorksheetFunction.Ceiling((lr - 1) / 3, 1) + 1 Cells(j, col) = Sheet1.Cells(j + i - 2, 1) Cells(j, col + 1) = Sheet1.Cells(j + i - 2, 2) Cells(j, col + 2) = Sheet1.Cells(j + i - 2, 3) Next j col = col + 4 Next i Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub بالتوفيق

وعليكم السلام حل آخر تعديل على تقسيم-جدول-على-3-جداول-VBA-Solution.xlsm

تفضل اخى الكريم الملف بعد ازالة التحديد كود نسخ البيانات.xlsm

وعليكم السلام تفضل البطاقة المدرسية.xlsm

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

غير الكود إلى Sub TR7el() Dim wk, wk2 As Worksheet Dim ro, ro4 As Long Set wk = Worksheets("رصد2") Set wk2 = Worksheets("شيت2") ro4 = wk2.Range("A" & Rows.Count).End(xlUp).Row If ro4 >= 10 Then wk2.Range("A10:CH" & ro4) = "" ro = wk.Range("B" & Rows.Count).End(xlUp).Row wk.Range("B8:D" & ro & ",G8:CK" & ro).Copy wk2.Range("A10").PasteSpecial Paste:=xlPasteValues End Sub وخبرني

بسم الله الرحمن الرحيم السلام عليكم ورحمه الله وبركاته اساتذتي واخوتى هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء يوجد فورم يمكنك البحث بها كما يمكنكم استخدام الفلتر العادي وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف تم تحديث الملف يوم الخميس الموافق 10 - 04 - 2025 فهرس منتدي الاكسيل.xlsb

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** الكود الاول هذا كود يجعل صفحة الاكسيل عندما تكتب فيها تكتب باللغة العربيه دائما حتى ولو كانت لغة الكتابة في لوحة المفاتيح انجليزي طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على This Workbook ستجد Private Sub Workbook_Open() hosami "00000401", 1 End Sub انسخه والصقة في ملفك الجديد في نفس الموقع This Workbook ثم اضغط على موديول 1 سيتم فتح الموديول هذا Declare Function hosami Lib _ "user32" Alias "LoadKeyboardLayoutA" (ByVal A As String _ , ByVal B As Long) As Long انسخه وضعه في نفس المكان وهو موديول 1 في ملفك الجديد احفظ الملف واعد فتحه ولاحظ لغة الكتابه في لوحة المفاتيح ودمتم في حفظ الله تغيير لغة الكي بورد الى العربي.rar تغيير لغة الكي بورد الى العربي بطريقة اخرى.rar

تفضل الملف بعد التعديل بدون كود وهذا الكود إذا كنت تحتاج الكود لملف آخر مع تعديل أرقام الصفوف والأعمدة حسب حاجتك Sub t() For i = 1 To 8 Range(Cells(1, 9), Cells(30, 9)).Select Selection.Cut Range(Cells(1, i), Cells(30, i)).Select Selection.Insert shift:=xlToRight Next End Sub عكس اعمدة الجدول مع تجميع خلايا الجدول.xlsx

بعد اذن الأستاذ محمدي عبد السميع حتى لا يتأخر طلب الغالي spyhearts Private Sub Worksheet_Selectionchange(ByVal Target As Range) If Target.Column = 3 And Target.Row = 5 Then ChaingeLanguage "English" Else ChaingeLanguage "Arabic" End If End Sub

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

وعليكم السلام ورحمة الله وبركاته تفضل =SUMIFS($B$2:$G$2;B3:G3;">0") SUM hour.xlsx

انظر ان كان هذا مطلوبك Aziz2.rar

تفضل اخى الملف اى بيان يضاف فى شيت رصد2 بمجرد فتح شيت 2 ستجد البيانات تم نسخها تركت لك زر المسح شغال واوقفت زر الترحيل كود نسخ البيانات.xlsm

والثالثة : أن تضيف حقل من نوع (نعم/لا) وتجعل هذا السجل (نعم) وتستثنيه من الحذف عند التفريغ .. 🙂

امامك طريقتين الاولى : ان تجعل السجل هذا في جدول خاص لا يشمله التفريغ .. وبعد التفريغ تعمل استعلام الحاق .. لنسخ السجل الى الجدول المطلوب الثانية : ان تكون بيانات السجل مكتوبة في الكود داخل محرر الفيجوال .. وبعد التفريغ تشغل الكود لنسخ هذه البيانات الى الجدول في المرفق ادناه طبقت الطريقة الثانية : DoCmd.RunSQL "INSERT INTO tbl1 ( id, sUser, sName ) SELECT ""15"" , ""0547812356"" , ""احمد فهمي"" " test.rar

ههههه ... عرفنا كيف نصيدك كلنا في شوق وشتياق لابداعاتك ... وشكرا مقدما لك ... بارك الله فيك

شكر لك أخي @kanory بالفعل هناك تحديث قادم بإذن الله 🙂 .. وهذه صورة تشويقية .. وسأذكر المميزات الجديدة في حينها إن شاء الله ..😊 وربما يصعب إدراج النماذج الفرعية هنا لأن المكان صاير زحمة 😅🖐🏼️

السلام عليكم ورحمة الله وبركاته اولا اود ان اشكر الاساتذة الافاضل الذين طالما لم يبخلوا علي بمساعدة وجل ما تعلمته ووضعته في هذا البرنامج اما بمساعدتهم المباشرة او بما قدموه من اعمال برنامج البسيط لشئون الطلاب ( مجاني تماما) يصلح للمدارس من رياض الاطفال والابتدائي والاعدادي بيانات التلاميذ متضمنة استخراج النوع وتاريخ الميلاد والسن في اول اكتوبر والمحافظة من الرقم القومي واستخراج البريد الموحد وكلمة المرور من الكود والرقم القومي للصفوف من الرابع للثالث الاعدادي سجل القيد قوائم 40 تلميذ قوائم 60 تلميذ قوائم 80 تلميذ سجل التقييمات للصفوف الاولى ورياض الاطفال سجل التقييمات للصفوف العليا والاعدادي سجل الغياب مع امكانية تصدير ملف الغياب كاكسيل سواء قبل ملء الغياب او بعده سجل النشاط الرياضي سجل المصروفات بنوعين 1 -يستخرج المسدد وغير المسدد 2 - انواع السداد سواء كامل او ضمان او ابناء عاملين سجلات 100 مليون صحة سجل للكتب للصفوف الاولى / الصفوف العليا / الاعدادي الاحصاء العامة للمدرسة احصاء للفصول احصاء المصروفات ( مسدد / غير مسدد / ضمان / ابناء عاملين / ايتام) سجلات قابلة لتعديل البيانات العناوين مثل التقييمات والصحة والرياضي حذف جميع البيانات بضغطة زر ترحيل التلاميذ للصفوف الاعلى امكانية النسخ من ملف قديم يبدا من الاصدار الرابع ليتم بصورة سليمة ارجو ان يحقق الفائدة للجميع رابط البرنامج https://top4top.io/downloadf-2780bcqwh1-rar.html رابط اخر https://www.mediafire.com/file/y503r9sdhbcroxz البسيط اعدادي.xlsb البسيط تعليم اساسي.xlsb البسيط لشئون ابتدائي ورياض.xlsb

السلام عليكم للنسخ بدون زر ضع نفس الكود فى حدث change لشيت رصد2 او فى حدث activate لشيت 2

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

ماني فاهم النسخ يتم للقيم فقط صور هذا التنسيق

تفضل كود نسخ البيانات.xlsm

استخدم هذا ............... If DCount("dates", "aa") > 0 Then Cancel = True MsgBox "هذا التاريخ مسجل مسبقا", vbCritical, "عملية خاطئة" Else DoCmd.GoToRecord , , acNewRec dates = Date End If

بسم الله الرحمان الرحيم السلام عليكم أعضاء منتدى اوفيسنا بدون اطالة .. المطلوب كالاتي لدي ملفات نفس الامتداد و الفورم محتوى الملف من الداخل قمت بانشاء ملف XLSM جاهز لجلب النتائج من العمود (الرقم) الى غاية العمود معدل (الفصل1) بعد عملية الجلبفي sheet1 النتيجة كالآتي: وفي نفس الوقت يقوم بنسخ عنوان الجدول في الخلية A5 في الصورة الاولى ولصقها في sheet2 في الخلية A1 اما في الخلية C2 بانشاء معدالة تقوم باختصار العنوان الرئيسي الى رمز للقسم الذي تم جلب نتائج تلاميذه وهذه المعادلة بعدها يقوم بنسخ الرمز ولصقه في الورقة sheet1 وهنا المشكلة....... عند عملية اللصق ... يقوم بلصقها عند اول خلية مع اول تلميذ ... نفس العملية عند جلب نتائج القسم الثاني ... المطلوب اريدتكرار لصق رمزالقسم عدة مرات مع نهاية صف كل قسم مثل ماهو في الصورة وهذا هو الكود الذي يقوم بالعملية Sub Import_4M() Dim filetoopen As Variant Dim openbook As Workbook Dim lastrow As Long Dim lastrow1 As Long Application.ScreenUpdating = False Application.DisplayAlerts = False filetoopen = Application.GetOpenFilename(Title:="Browse your file", filefilter:="Excel files (*.xls),*.xls") If filetoopen <> False Then Set openbook = Application.Workbooks.Open(filetoopen) lastrow1 = openbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row - 1 openbook.Sheets(1).Range("A7:T" & lastrow1).Copy lastrow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row + 1 ThisWorkbook.Worksheets("Sheet1").Range("B" & lastrow).PasteSpecial xlPasteValues openbook.Sheets(1).Range("A5").Copy ThisWorkbook.Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteValues ThisWorkbook.Worksheets("Sheet2").Range("C1").Copy ThisWorkbook.Worksheets("Sheet1").Range("A" & lastrow).PasteSpecial xlPasteValues openbook.Close False End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

أعتذر أخي عن التأخر في الرد إليك الملف التالي فيه التعديل .. الملف معتمد على الملف الذي قمت بإرفاقه من قبل .. حيث وجدت ملفك المرفق يحتاج لنفس الخطوات التي قمنا بها من قبل وفي هذا مشقة .. أرجو أن يفي بالغرض إن شاء الله Grab Data By Hijri Dates Using Arrays YasserKhalil V2.rar

أخي الكريم موريادي قمت بعمل أعمدة مساعدة في الورقة المسماة Report عمود لإدراج الشهور الهجرية فيه .. وعمود لإدراج السنوات .. وفي الخلية I1 معادلة لمعرفة رقم الشهر الهجري ومقارنته أثناء عمل الكود تقوم بالاختيار من القائمة المنسدلة الشهر المطلوب وليكن "شعبان" ثم تختار السنة الهجرية من الخلية المجاورة F2 .. ثم أخيراً انقر على زر الأمر لجلب البيانات من ورقة العمل Data تم استخدام المصفوفات في الأكواد لسرعتها في التعامل مع البيانات الكبيرة Sub Test() 'Author : YasserKhalil 'Release : 29 - 08 - 2016 '------------------------ Dim Ws As Worksheet, Sh As Worksheet Dim Arr, Temp Dim Lr As Long, I As Long, P As Long Dim lMonth As Integer, lYear As Integer Set Ws = Sheets("Data"): Set Sh = Sheets("Report") Lr = WorksheetFunction.CountA(Ws.Columns(2)) lMonth = Sh.Range("I1").Value lYear = Sh.Range("F2").Value Arr = Ws.Range("A2:H" & Lr).Value ReDim Temp(1 To UBound(Arr, 1), 1 To 3) For I = 1 To UBound(Arr, 1) If Month(DHijri(CDate(Arr(I, 5)))) = lMonth And Year(DHijri(CDate(Arr(I, 5)))) = lYear Then Temp(P + 1, 1) = Arr(I, 4) Temp(P + 1, 2) = Arr(I, 5) Temp(P + 1, 3) = Arr(I, 8) P = P + 1 End If Next I Sh.Range("A6:C10000").ClearContents If P > 0 Then Sh.Range("A6").Resize(P, UBound(Temp, 2)).Value = Temp MsgBox "Done...", 64 Else MsgBox "No Data For This Month And This Year", vbExclamation End If End Sub Function DHijri(dtGegDate As Date) As String VBA.Calendar = vbCalHijri DHijri = dtGegDate VBA.Calendar = vbCalGreg End Function أرجو أن يفي هذا بالغرض إن شاء الله تقبل تحياتي Grab Data By Hijri Dates Using Arrays YasserKhalil.rar

هل يوجد شرح لعمل القائمة المنسدلة فى شيت 2

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