ياسر خليل أبو البراء

بارك الله فيك أخي الحبيب ومعلمي الكبير أحمد يعقوب وهذا ملف للأستاذ الكبير محمد الريفي بالمعادلات إثراءً للموضوع Transpose Rows And Columns.rar

جرب الكود التالي لعله يفي بالغرض (ومن غير شريط تقدم هيكون سريع إن شاء الله) Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim temp As Variant Dim i As Long Dim j As Long Dim p As Long Dim sW As Double Dim sM As Double Set ws = Sheets("Data") Set sh = Sheets("Report") arr = ws.Range("B2").CurrentRegion.Value ReDim temp(1 To UBound(arr, 1), 1 To 2) For i = 2 To UBound(arr, 1) If arr(i, 2) <> "" Or arr(i, 3) <> "" Then p = p + 1 temp(p, 1) = arr(i, 1) sW = sW + Val(arr(i, 2)) sM = sM + Val(arr(i, 3)) temp(p, 2) = sW - sM End If Next i With sh .Columns("E:F").ClearContents .Range("E3:F3").Value = Array("التاريخ", "الرصيد التراكمي") .Range("E4").Resize(p - 1, UBound(temp, 2)).Value = temp End With End Sub

أليس الموضوع مكرر أم أن الطلب مختلف هنا في الموضوع؟؟!!

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

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

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

جرب اعمل كليك يمين على زر الـ Spin ثم Assign Macro ... وحول الماكرو الموجود لماكرو عادي في موديول عادي امسح الماكرو الموجود في حدث ورقة العمل ، وضع الكود التالي في موديول .. واعمل كليك يمين Assign Macro واختر اسم الماكرو Test ... لربط الزر بتنفيذ الكود Sub Test() Dim s As Worksheet Dim t As Worksheet Dim v As Variant Dim r As Long Set s = Sheets("تسجيل البيانات") Set t = Sheets("الكشوف النهائية") v = t.Range("P1").Value If Not IsNumeric(v) Or IsEmpty(v) Or v > 4 Then t.Range("B14").Resize(6, 4).ClearContents: Exit Sub r = (v * 6) + 5 t.Range("B14").Resize(6, 4).Value = s.Range("A" & r).Resize(6, 4).Value End Sub

وعليكم السلام أخي محمد جرب الكود التالي Private Sub UserForm_Initialize() Label2 = Application.WorksheetFunction.COUNTA(Range("B2:B200")) End Sub

لم أفهم المشكلة للآن .. الكود يقوم بعملية المسح بداية من الصف رقم 8 وإلى آخر رقم صف .. ورقم الصف متغير من ورقة لأخرى .. حاول توضح المشكلة بالصور لكي أفهم أين الخلل؟؟! بعد الإطلاع على الملف .. وبشغل التخمين جرب السطر التالي .. ابحث عنه في الكود واستبدله بهذا السطر sh.Range("A8").Resize(Rows.Count - 7, lc).Clear ولكن هذا سيستغرق وقت أطول بقليل .. من المفترض أن تقوم بضبط الملف لأول مرة بشكل يدوي بحيث لا يكون هناك خلايا بها تنسيق .. عموماً ممكن بعد تنفيذ الكود بهذا السطر الجديد يمكنك استخدام السطر القديم لأنه لن تكون بحاجة إلى مسح كل هذا الكم من الصفوف .. هذا والله أعلم

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

في الحقيقة اطلعت ولم أوفق في حل المشكلة .. أنا لا أتردد عن المشاركة إذا كان لدي علم بالأمر .. فلا تحزن من عدم مشاركتي !

اعمل كليك يمين على الأداة Spinner وستجد أمر Format Control وفي آخر تبويب ابدأ في التعامل .. وحدد الخلية المطلوب ربطها بالأداة Link Cell ...

في الملف المرفق الجديد أيضاً قم بتعديل نفس السطر If Intersect(Range("A1:D1"), Target) Is Nothing Then بصراحة المشكلة في إني مش بقدر افهم المطلوب بشكل كويس .. ولذلك يفضل وضع صورة بالمطلوب .. ضع المعطيات وشكل النتائج المتوقعة في صورة أفضل حتى يسهل التواصل فيما بيننا

أخي العزيز ناصر جرب الكود التالي عله يفي بالغرض ... امسح الأكواد الموجودة في الموديولات لأن هناك كودين بنفس الاسم Test وهذا لا يجوز .. ضع الكود التالي في حدث الفورم بعد مسح الكود القديم ، والشكر موصول للأخ الغالي ياسر العربي صاحب الفكرة الرائعة Private Sub CommandButton1_Click() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Dim lc As Long Dim c As Long Set ws = Sheets("بيانات الطلبة") c = ws.Range("Q1").Value If TextBox1.Text = ws.Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64 Application.ScreenUpdating = False Application.Calculation = xlManual If ws.Range("Q1") < 2 Then Exit Sub End If For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "كشف ناجح")) lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh)) lc = LastOccupiedColNum(sh) sh.Range("A8").Resize(lr + 7, lc).Clear sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc) Next sh Application.Goto ws.Range("A1") Application.Calculation = xlAutomatic Application.ScreenUpdating = True Unload Me Else MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation TextBox1.Text = "" TextBox1.SetFocus End If End Sub Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long Dim lng As Long If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then With Sheet lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row End With Else lng = 1 End If LastOccupiedRowNum = lng End Function Public Function LastOccupiedColNum(Sheet As Worksheet) As Long Dim lng As Long If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then With Sheet lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column End With Else lng = 1 End If LastOccupiedColNum = lng End Function

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

غير السطر التالي If Intersect(Range("A1:D1"), Target) Is Nothing Then

أخي الكريم يبدو أن الخطأ من عندي .. في هذا السطر If Target.Address = "$G$1" Then استبدل حرف الـ G بحرف الـ P أو يمكنك تجربة الكود كما هو وقم بإدخال رقم المجموعة في الخلية G1

هل اطلعت على المشاركة السابقة والملف المرفق .. لأنك لم تعلق عليه ، حاول أن تتبع نفس الأسلوب في ورقة العمل "كنترول شيت" وورقة العمل "كنترول شيت (2)" وورقة العمل "رصد الترم الأول" وورقة العمل "Sheet1" ليسوا بنفس الهيكلة أي أن البيانات لا تبدأ من الصف السابع كبقية الأوراق . فهل هذه أوراق سيتم استثنائها؟ ولما لا ترفق نموذج مصغر كالذي أرفقته ليسهل العمل عليه .. اطلع على المرفق أعلاه في المشاركة السابقة وفيه نفس الفكرة حيث يتم عمل حلقة تكرارية لأوراق العمل ثم يتم تحديد رقم آخر عمود بناءً على وجود متغير يتم مقارنته في كل مرة مع رقم آخر عمود بالورقة التي عليها الدور في الحلقة التكرارية

أخي الكريم محمود بالمثال يتضح المقال .. ضع ملف مرفق بسيط موضحاً فيه المطلوب

ارفق الملف الذي قمت بوضع الكود لمعرفة الخلل

أخي الكريم الموضوع بسيط اعمل كليك يمين على اسم ورقة العمل المسماة "الكشوف النهائية" .. واختر الأمر View Code .. وانسخ الكود من المشاركة (بس خلي اتجاه لغة الكتابة باللغة العربية عند النسخ) ، وبعدين روح للنافذة اللي اتفتحت والصق الكود وبس خلاص الكود هيتنفذ بمجر وضع رقم في الخلية P1 في ورقة "الكشوف النهائية" ..

وعليكم السلام دعك من تحميل الملف المهم الكود .. استخدم الكود الموجود في الموضوع .. الملف ما هو إلا مثال تطبيقي على الكود Sub Create_PDF_Files_For_Each_Sheet() Dim Ws As Worksheet Dim Fname As String Application.ScreenUpdating = False For Each Ws In ActiveWorkbook.Worksheets On Error Resume Next Fname = ThisWorkbook.Path & "\Exported " & Ws.Name Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fname, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False Next Ws Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub

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

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

نعم أخي الكريم عموماً رأيت اليوم مقال يخص طلبك لربما يفيدك ..حاول الإطلاع عليه وإن شاء الله تقدر تستفيد منه https://www.myonlinetraininghub.com/clear-downstream-dependent-data-validation-lists