ليلى الهلالي

للرفع

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

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

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

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

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

أتبع هذه الراوابط قد تجد فيها ما يفيد https://www.officena.net/ib/topic/89479-طلب-طريقة-فك-حماية-ورقة-اكسل/?tab=comments#comment-563053

السلام عليكم ورحمة الله وبركاته الملف الذي رفعته يبدو أنه معطوب حيث لم يقبل أن يفتح لديّ

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

السلام عليكم أعتذر لعدم تحميل المرفق حيث توقف النت لديّ حافظة الدوام أوفيسنا.rar

السلام عليكم ورحمة الله وبركاته خواتم مباركة ومرضية وجدت كود للأستاذ القدير ياسر خليل وأرجو منكم مساعدتي في معرفة المتغيرات أو الجزئيةأو ما يلزم لتغييره كي يتناسب مع ملفي. حيث أريد أن أرحل المعلمين من حافظة الدوام إلى ملف منفصل لكل مدرسة مع نسخ تنسيقات الحافظة. والكود كالتالي Sub Export_Workbooks_Using_Filter() 'Author : YasserKhalil 'Release : 07 - 09 - 2016 '------------------------ Dim a As Variant Dim I As Long Dim P As Integer Dim cnt As Integer Dim Dic As Object Dim strDir As String Dim Arr() As Double Dim iFlag As Boolean '========================================================= Const firstCol As Long = 1 'First Column Const lastCol As Long = 4 'Last Column Const colNo As Long = 1 'Column To Filter Const sSheet As String = "Sheet1" 'Sheet Name '========================================================= strDir = ThisWorkbook.Path & "\Output\" For P = firstCol To lastCol ReDim Preserve Arr(P - 1) Arr(P - 1) = Sheets(sSheet).Columns(P).ColumnWidth Next P iFlag = Sheets(sSheet).DisplayRightToLeft Call SpeedUp If Dir(strDir, vbDirectory) = "" Then MkDir strDir Sheets.Add before:=Sheets(1) Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMOde = 1 With Sheets(sSheet).[A1].CurrentRegion .Columns(colNo).Value = Application.Trim(.Columns(colNo).Value) a = .Value .Parent.AutoFilterMode = False For I = 2 To UBound(a, 1) If Not Dic.exists(a(I, colNo)) And Not IsEmpty(a(I, colNo)) Then Dic(a(I, colNo)) = Empty .AutoFilter colNo, a(I, colNo) .Copy Sheets(1).Cells(1) Sheets(1).Copy With ActiveWorkbook With Sheets(1) .Name = "Sheet1" .DisplayRightToLeft = iFlag .Cells(1).CurrentRegion.RowHeight = 19 For cnt = firstCol To lastCol .Columns(cnt).ColumnWidth = Arr(cnt - 1) Next cnt End With .SaveAs strDir & RemoveSpecial(CStr(a(I, colNo))) & ".xlsx" .Close End With Sheets(1).Cells.Clear .AutoFilter End If Next I End With Sheets(1).Delete Call SpeedDown MsgBox "Done...", 64 End Sub Function RemoveSpecial(sInput As String) As String Dim sSpecialChars As String Dim I As Long sSpecialChars = "\/:*?""<>|" For I = 1 To Len(sSpecialChars) sInput = VBA.Trim(Replace$(sInput, Mid$(sSpecialChars, I, 1), " ")) Next I RemoveSpecial = sInput End Function Function SpeedUp() With Application .Calculation = xlManual .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False End With End Function Function SpeedDown() With Application .Calculation = xlAutomatic .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With End Function

السلام عليكم أخي الفاضل عبدالفتاح شهر مبارك لقد عدلت في الكود وقد قام بعملية الترحيل بحسب ما وضعته أنت في الكود. ولكني لم افهم ما هو المطلوب ترحيله بالضبط هل تريد ترحيل البيانات التي في الأعمدة أم كما هو موجود في المرفق الذي أرسلته؟ جرب الكود قد يكون هو المطلوب Option Explicit Sub transferData() Dim i As Long Dim lastrow As Long Dim erow As Long lastrow = Sheets("æÑÞÉ1").Range("a" & Rows.Count).End(xlUp).Row For i = 3 To lastrow erow = Sheets("æÑÞÉ2").Range("a" & Rows.Count).End(xlUp).Offset(1, 0).Row Range(Cells(i, 1), Cells(i, 6)).Copy Destination:=æÑÞÉ2.Cells(erow, 1) Next i Cells(erow, 6) = WorksheetFunction.Sum(Worksheets("æÑÞÉ2").Range("e3:e35")) End Sub

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

أستاذي الفاضل وائل: أعتذر منك لكني لم أجد المعادلات؟؟

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