وعليكم السلام ورحمة الله وبركاته
واجهت هذه المشكلة م قبل وكنت احتاجها لطباعة شهادات الطلاب آخر العام
لأنه يوجد في الشهادة خانة : الاسم الرباعي , وخانة اللقب (المجموع اسم خماسي )
حاولت عمل عدة حلول وبعضها تحتاج إلى عمودين : عمود للاسم الرباعي وعمود للقب ولم أرتضي هذا الحل حتى توصلت في النهاية إلى حل ولا زلت أستخدمه إلى الآن منذ 6 سنوات وهو يعمل معي بدون مشاكل وبدون أعمدة مساعدة
اكتب الاسم في خلية واحدة فقط .
الحل من قسمين :
القسم الاول : هو فصل اللقب بمسافتين وكتابة بقية الاسماء (سواء كانت ثلاثية أو رباعية أو غيره ) بمسافة واحدة بين الأسماء
مثال : أحمد سعيد أحمد الأحمدي (خطأ)
أحمد سعيد أحمد الأحمدي (صحيح)
تلاحظ مسافتين قبل كلمة الاحمدي وبقية الاسماء بينها مسافة واحدة فقط
وبعدها عملت تنسيق شرطي على كامل عمود الاسم , فأي اسم لا يحوي على مسافتين يلون الخلية بالأحمر
وأذا كان الاسم سليما تكون الخلية بلون ابيض عادي
نحرص على كتابة الاسم الرباعي للطالب ثم اللقب يكون الخامس
أحيانا يأتي لنا طالب لا نعرف اسمه الخماسي فأضطر اكتبه كله بمسافة واحدة فقط حتى يتم تلوين الخلية بلون أحمر حتى يلفت نظري كلما فتحت الملف , وأن هذا الطالب فيه مشكلة بالتالي يسهل الرجوع إلى الأسماء الناقصة في المدرسة كلها
القسم الثاني :
أحيانا عند الكتابة السريعة و ادخال أسماء الطلاب أضيف بالخطأ في بداية أو نهاية الاسم مسافة مما يسبب ظهور الاسم في الشهادة بشكل ناقص , فأحرص على الغاء المسافات في البداية وفي النهاية
عملت تنسيق شرطي يلون لي كل الأسماء التي فيها مسافة في البداية أو النهاية بلون أخضر ثم أقوم بالدخول للاسم ومسح المسافة (في البداية أو النهاية وترجع الخلية بلونها الأبيض
تفضل جرب هذا من الذكاء الاصطناع
==============
Sub sale_m_Optimized()
Dim wsItemOut As Worksheet, wsPerform As Worksheet, wsAccMove As Worksheet
Dim wsAccMoveD As Worksheet, wsItemMove As Worksheet
Dim lastRow As Long, i As Long, nRows As Long
Dim dataArr As Variant
Dim performArr As Variant, accMoveDArr As Variant
Dim itemMoveArr As Variant, accMoveArr As Variant
Dim docType As String, isReturn As Boolean
Dim performStart As Long, accMoveDStart As Long
Dim itemMoveStart As Long, accMoveStart As Long
On Error GoTo CleanUp
' ═══════════════════════════════════════
' إيقاف كل ما يبطئ التنفيذ
' ═══════════════════════════════════════
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' ═══════════════════════════════════════
' تعريف الأوراق (مرة واحدة فقط)
' ═══════════════════════════════════════
Set wsItemOut = ThisWorkbook.Sheets("itemout")
Set wsPerform = ThisWorkbook.Sheets("perform")
Set wsAccMove = ThisWorkbook.Sheets("accmove")
Set wsAccMoveD = ThisWorkbook.Sheets("AccMove D")
Set wsItemMove = ThisWorkbook.Sheets("itemmove")
' إيقاف الفلاتر
On Error Resume Next
wsPerform.Rows("4:4").AutoFilter
wsAccMoveD.Rows("4:4").AutoFilter
wsAccMove.Rows("3:3").AutoFilter
wsItemMove.Rows("4:4").AutoFilter
wsItemOut.Rows("7:7").AutoFilter
On Error GoTo CleanUp
' ═══════════════════════════════════════
' التحقق من البيانات الإلزامية
' ═══════════════════════════════════════
With wsItemOut
If .Cells(2, 2) = "" Or .Cells(5, 2) = "" Or .Cells(8, 2) = "" Or .Cells(2, 5) = "" Then
MsgBox "أكمل البيانات: نوع الحركة, كود العميل, كود الصنف, الإذن اليدوي"
.Range("B8").Select
GoTo CleanUp
End If
End With
' ═══════════════════════════════════════
' قراءة القيم الثابتة مرة واحدة
' ═══════════════════════════════════════
docType = wsItemOut.Cells(2, 2).Value
isReturn = (docType = "مردودات مبيعات")
' ═══════════════════════════════════════
' حساب عدد صفوف البيانات
' ═══════════════════════════════════════
lastRow = wsItemOut.Cells(wsItemOut.Rows.Count, 2).End(xlUp).Row
If lastRow < 8 Then GoTo CleanUp
nRows = lastRow - 7
' قراءة كل بيانات المصدر في مصفوفة واحدة (B8:M...)
dataArr = wsItemOut.Range("B8:M" & lastRow).Value
' ═══════════════════════════════════════
' حساب صف البداية في كل شيت (مرة واحدة)
' ═══════════════════════════════════════
performStart = wsPerform.Cells(wsPerform.Rows.Count, 1).End(xlUp).Row + 1
accMoveDStart = wsAccMoveD.Cells(wsAccMoveD.Rows.Count, 1).End(xlUp).Row + 1
itemMoveStart = wsItemMove.Cells(wsItemMove.Rows.Count, 1).End(xlUp).Row + 1
accMoveStart = wsAccMove.Cells(wsAccMove.Rows.Count, 1).End(xlUp).Row + 1
' ═══════════════════════════════════════
' تهيئة المصفوفات للشيتات الأربعة
' ═══════════════════════════════════════
ReDim performArr(1 To nRows, 1 To 21) ' B:V
ReDim accMoveDArr(1 To nRows, 1 To 21) ' B:V
ReDim itemMoveArr(1 To nRows, 1 To 14) ' B:O
ReDim accMoveArr(1 To nRows, 1 To 19) ' B:T
' ═══════════════════════════════════════
' حلقة واحدة فقط لملء المصفوفات الأربع
' ═══════════════════════════════════════
For i = 1 To nRows
' ═══ شيت perform (أعمدة B:V) ═══
performArr(i, 1) = wsItemOut.Cells(3, 2).Value ' B
performArr(i, 2) = wsItemOut.Cells(4, 2).Value ' C
performArr(i, 3) = wsItemOut.Cells(5, 2).Value ' D
performArr(i, 4) = wsItemOut.Cells(6, 2).Value ' E
performArr(i, 5) = wsItemOut.Cells(2, 5).Value ' F
performArr(i, 6) = dataArr(i, 1) ' G (من B)
performArr(i, 7) = dataArr(i, 2) ' H (من C)
performArr(i, 😎 = dataArr(i, 3) ' I (من D)
performArr(i, 9) = dataArr(i, 4) ' J (من E)
' K: الكمية (سالب إذا لم يكن مردود)
If Not isReturn Then
performArr(i, 10) = dataArr(i, 5) * -1
Else
performArr(i, 10) = dataArr(i, 5)
End If
performArr(i, 11) = dataArr(i, 6) ' L (من G)
performArr(i, 15) = "no" ' P
performArr(i, 21) = docType ' V
' ═══ شيت AccMove D (أعمدة B:V) ═══
accMoveDArr(i, 1) = wsItemOut.Cells(3, 2).Value ' B
accMoveDArr(i, 2) = wsItemOut.Cells(4, 2).Value ' C
accMoveDArr(i, 3) = wsItemOut.Cells(5, 2).Value ' D
accMoveDArr(i, 4) = wsItemOut.Cells(6, 2).Value ' E
accMoveDArr(i, 5) = wsItemOut.Cells(2, 5).Value ' F
accMoveDArr(i, 6) = dataArr(i, 1) ' G
accMoveDArr(i, 7) = dataArr(i, 2) ' H
accMoveDArr(i, 😎 = dataArr(i, 3) ' I
accMoveDArr(i, 9) = dataArr(i, 4) ' J
accMoveDArr(i, 10) = dataArr(i, 5) ' K
accMoveDArr(i, 11) = dataArr(i, 6) ' L
accMoveDArr(i, 15) = "no" ' P
accMoveDArr(i, 21) = docType ' V
' ═══ شيت itemmove (أعمدة B:O) ═══
itemMoveArr(i, 1) = dataArr(i, 1) ' B
itemMoveArr(i, 2) = dataArr(i, 2) ' C
itemMoveArr(i, 3) = dataArr(i, 3) ' D
itemMoveArr(i, 4) = dataArr(i, 4) ' E
itemMoveArr(i, 5) = docType ' F
itemMoveArr(i, 6) = wsItemOut.Cells(3, 2).Value ' G
itemMoveArr(i, 7) = wsItemOut.Cells(2, 5).Value ' H
' I/J: نفس المنطق الأصلي (أعمدة مختلفة حسب نوع الحركة)
If Not isReturn Then
itemMoveArr(i, 9) = dataArr(i, 10) ' J (من K في المصدر)
Else
itemMoveArr(i, 😎 = dataArr(i, 10) ' I (من K في المصدر)
End If
itemMoveArr(i, 11) = wsItemOut.Cells(5, 2).Value ' L
itemMoveArr(i, 12) = dataArr(i, 12) ' M (من M في المصدر)
itemMoveArr(i, 14) = wsItemOut.Cells(4, 2).Value ' O
' ═══ شيت accmove (أعمدة B:T) ═══
accMoveArr(i, 1) = wsItemOut.Cells(5, 2).Value ' B
accMoveArr(i, 2) = wsItemOut.Cells(6, 2).Value ' C
accMoveArr(i, 4) = wsItemOut.Cells(3, 2).Value ' E
accMoveArr(i, 5) = wsItemOut.Cells(2, 5).Value ' F
accMoveArr(i, 6) = wsItemOut.Cells(4, 2).Value ' G
' H/I: نفس المنطق الأصلي
If Not isReturn Then
accMoveArr(i, 7) = wsItemOut.Cells(36, 8).Value ' H
Else
accMoveArr(i, 😎 = wsItemOut.Cells(36, 8).Value ' I
End If
accMoveArr(i, 10) = dataArr(i, 5) ' K
accMoveArr(i, 11) = wsItemOut.Cells(34, 8).Value ' L
accMoveArr(i, 13) = wsItemOut.Cells(35, 8).Value ' N
accMoveArr(i, 15) = docType ' P
accMoveArr(i, 18) = wsItemOut.Cells(5, 3).Value ' S
ممكن وبكل سهولة
هذا البرنامج يسهل عليك أدخال الدرجات والتاريخ كذلك
الشرح يطول ولكن ثق تماما أنك بمجرد أن تفتحه وتثبت الماكرو وتستخدمه ستفهم البرنامج
ثم بعد التجربة أذا أردت أي توضيح نحن في الخدمة
محرر الأكواد مفتوح ويمكنك التعديل عليه كما تريد
الطريقة : افتح ملفك الذي تريد الأدخال فيه ثم افتح هذا الملف
ثم اضغط على إحدى الأيقونتين (الدرجات أو التاريخ)
وعندما يفتح الفورم انتقل مباشرة إلى ملفك الذي تريد الأدخال فيه
ستجد أن الفورم ينتقل إلى الملف الجديد
تفضل
إدخال الدرجات والتاريخ.xls
وعليكم السلام ورحمة الله وبركاته
الطريقة
حدّد كل الجدول (أو النطاق الكبير اللي تشتغل فيه).
من القائمة: اختر
(تنسيق شرطي) ثم (قاعدة جديدة) ثم (استخدام صيغة لتحديد الخلايا المراد تنسيقها)
اكتب الصيغة التالية:
=ROW()=CELL("row")
اختر اللون اللي تحبّه.
اضغط (موافق)
الأن كلما تكتب في أي خلية في السطر اضغط السهم لليمين أو اليسار وواصل الكتابة ـ يعني لاتنزل سطر جديد ولكن تابع الكتابة في نفس السطر
إذا تطابق اللون والوصف والمقاس سيتم ألغاء الإضافة
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim WS As Worksheet, rng As Range
Dim lastRow As Long
Set WS = Sheet1
If Me.TextBox4 = "" Then: Exit Sub
'=======
lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow ' äÈÏà ãä ÇáÕÝ 2 assuming ÇáÕÝ ÇáÃæá ÚäÇæíä
If WS.Cells(i, 2).Value = Me.TextBox1.Value _
And WS.Cells(i, 3).Value = Me.TextBox7.Value _
And WS.Cells(i, 4).Value = Me.TextBox2.Value _
Then
MsgBox "ÇáÈíÇäÇÊ ÇáÊí ÊÍÇæá ÃÖÇÝÊåÇ ãæÌæÏÉ ãä ÞÈá", vbOKOnly, "ÈíÇäÇÊ ãßÑÑÉ"
Exit Sub
End If
Next i
'=======
Set rng = WS.Range("a2100").End(xlUp).Offset(1, 0)
rng.Offset(0, 0).Value = Me.TextBox4.Value
rng.Offset(0, 1).Value = Me.TextBox1.Value
rng.Offset(0, 3).Value = Me.TextBox2.Value
rng.Offset(0, 5).Value = Me.TextBox3.Value
rng.Offset(0, 6).Value = Me.TextBox5.Value
rng.Offset(0, 7).Value = Me.TextBox6.Value
rng.Offset(0, 2).Value = Me.TextBox7.Value
For i = 1 To 7
Controls("textbox" & i).Text = Empty
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
السلام عليكم
هذه محاولة بحسب ما فهمت
حل1 : اختر أول سطر للبيانات من القائمة المنسدلة الزرقاء
حل2 : مباشرة بدون اختبار سيتم اختيار آخر سطر
تفضل
جديد1.xlsm
السلام عليكم
تم عمل بعض التغييرات في الملف حتى تمشي الأمور تمام التمام
تم فك الدمج في خلايا الاحتياط لأن معادلة الصفيف لا تقبل الخلايا المدموجة
فقط قم تبغيير الرقم في P1 ولاحظ النتيجة
ملاحظة : كل المعادلات من نوع الصفيف التي تبدأ بقوس وتنتهي بقوس
تفضل جرب الملف
وعليكم السلام
كل حاجة تمام التمام المعادلة شغالة في K2 , K3
الخلل موجود في الصفحة main في الخلية E2 لا يوجد تاريخ
ادخل على الصفحة والخلية واكتب اي تاريخ ستجد كل شيء تمام التمام
تحياتي
ساعرض عليك فيدوهات تشرح الطريقة ولكن يجب أن تشاهدها كلها حتى تختار أسهل طريقة تناسبك
أولا :
https://youtu.be/pA9ySmQ01iY?si=p9nXmux1nT8qBGgp
ثانيا :
https://youtu.be/sBBKTP1io_M?si=VmXjQmgihaoJqBBy
ثالثا :
https://youtu.be/lgbHqyDsfwg?si=oQzRCmGxXMVsNscA
