أكاديمية الصقر للتدريب

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


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





حذف بناء على شرط

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



21-07-2020 11:23 صباحا
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 

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

NDQ4NTg5MQ1818123
 
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  حذف بناء على شرط.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(28.444) KB


22-07-2020 02:16 مساء
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 231
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2149
عدد الإجابات: 28
 offline 
look/images/icons/i1.gif حذف بناء على شرط
السلام عليكم ورحمة الله
استخدم الكود التالى
Sub DelData()
Dim ws As Worksheet
Dim Had As String
Dim LR As Long, x As Integer
Set ws = Sheets("Sheet1")
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
i = 5
Do While i <= LR
Had = "الحديث"
On Error Resume Next
If WorksheetFunction.Find(Had, ws.Range("AK" & i), 1) > 0 Then
x = ws.Range("AK" & i).Row
ws.Cells(x + 1, 6).Resize(2, 26).ClearContents
End If
i = i + 4
Loop
End Sub

22-07-2020 08:39 مساء
مشاهدة مشاركة منفردة [2]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif حذف بناء على شرط
جزاك الله خيرا استاذ ابراهيم سلمت يداك
لكن الكود يقوم بمسح كل البيانات لكل طالب؟؟؟؟


تم تحرير المشاركة بواسطة :نصر الإيمان
بتاريخ:22-07-2020 08:51 مساء


22-07-2020 08:53 مساء
مشاهدة مشاركة منفردة [3]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif حذف بناء على شرط
المفترض ان الطالب الذ يكتب له باملاحظات شيء خلاف كلمة الحديث لا يتم المسح له
MzM5OTIx5328255
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
 
  حذف بناء على شرط22.rar   تحميل rar مرات التحميل :(3)
الحجم :(24.596) KB


23-07-2020 01:15 صباحا
مشاهدة مشاركة منفردة [4]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 231
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2149
عدد الإجابات: 28
 offline 
look/images/icons/i1.gif حذف بناء على شرط
السلام عليكم ورحمة الله
اجعل الكود هكذا
Sub DelData()
Dim ws As Worksheet
Dim Had As String
Dim LR As Long, x As Integer
Set ws = Sheets("Sheet1")
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
i = 5
Do While i <= LR
Had = "الحديث"
On Error GoTo nxt:
If WorksheetFunction.Find(Had, ws.Range("AK" & i), 1) <> 0 Then
x = ws.Range("AK" & i).Row
ws.Cells(x + 1, 5).Resize(2, 26).ClearContents
nxt:
i = i + 4
End If
i = i + 4
Loop
End Sub

23-07-2020 02:17 صباحا
مشاهدة مشاركة منفردة [5]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif حذف بناء على شرط
جزاك الله خيرا استاذ ابراهيم ....... سلمت يداك
لكن حل من حل في حذف الدوائر الحمراء للطالب ،،،، والشرطه المائله اكرمك الله
MzQ3MzQ3MQ464627855
 
 


23-07-2020 07:51 صباحا
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif حذف بناء على شرط
بارك الله فيك أخي العزيز إبراهيم وجزاك الله خيراً
استكمالاًُ للكود الموضوع جرب الإضافة التالية مع تعديلات في الكود ليصبح أكثر مرونة حيث وضعت متغيرات تحدد من خلالها عمود البداية وعدد الأعمدة والعمود الهدف الذي يحتوي النص المطلوب 
أرجو ان يفي الكود بالغرض إن شاء الله
Sub Clear_Contents_By_Specific_Condition_Delete_Shapes_Within_Range()
    Const colStart As Long = 5
    Const colCount As Long = 27
    Const colTarget As Long = 37
    Dim ws As Worksheet, sHad As String, lr As Long, x As Long, i As Long
    Application.ScreenUpdating = False
        Set ws = Sheets("Sheet1")
        lr = ws.Range("C" & Rows.Count).End(xlUp).Row
        sHad = Join(Array(Chr(199), Chr(225), Chr(205), Chr(207), Chr(237), Chr(203)), Empty)
        i = colStart
        Do While i <= lr
            If InStr(ws.Cells(i, colTarget), sHad) Then
                x = ws.Cells(i, colTarget).Row
                DeleteShapesWithinRange ws.Cells(x, colStart).Resize(4, colCount)
                ws.Cells(x + 1, colStart).Resize(2, colCount).ClearContents
            End If
            i = i + 4
        Loop
    Application.ScreenUpdating = True
End Sub

Sub DeleteShapesWithinRange(ByVal rng As Range)
    Dim shp As Shape
    For Each shp In rng.Parent.Shapes
        If Not Application.Intersect(shp.BottomRightCell, rng) Is Nothing Then shp.Delete
    Next shp
End Sub




الكلمات الدلالية
بناء ،


 










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

الساعة الآن 12:39 مساء