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

اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا




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

Preview

الرئيسية
نتائج البحث


نتائج البحث عن ردود العضو :salim
عدد النتائج (711) نتيجة
25-11-2020 05:01 مساء
icon لجان الدور الثاني حسب المادة وحسب الجنس | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 1-للمرة الـ 100 بعد الألف اختصار الملف ( لماذا اكثر من 500 طالب في كل ورقة)
2- انت وضعت 6 لجان كل واحدة تحتوي عل 15 اسم اي 90 طالب
    ما ادراك بعدد الطلاب (دور ثاني - ذكور  او  أناث)   كيف تعرف ان 6 لجان نكفيهم  ربما نحتاج الى 7 مثلاً أو 5 أو 10
3- كيف نعرف ان الطالب دور ثاني
4- على كل حال جرب هذا الماكرو

Option Explicit

Sub Get_data()
Application.EnableEvents = False
  Dim s_rg As Range, find_rg As Range
  Dim Mou3addaL#, last_Clas%, I%, m%, col%
  Dim Mal_Femal$
  Dim First_sheet As Worksheet
  Dim Second_sheet As Worksheet
  Dim Position%, k%
  Position = 19
  Set First_sheet = Sheets("ف.1.أ")
  Set Second_sheet = Sheets("اللجنة")
    Mal_Femal$ = Second_sheet.Cells(1, 7)
  For I = 4 To 300 Step Position
    If Second_sheet.Cells(I - 1, 2) = "" Then Exit For
    Second_sheet.Cells(I, 2).Resize(15, 3).ClearContents
  Next
If Mal_Femal = "" Then Exit Sub

last_Clas = First_sheet.Cells(Rows.count, 2).End(3).Row
Set find_rg = First_sheet.Rows(4).Find(Second_sheet.Cells(1, 6), lookat:=1)
If find_rg Is Nothing Then Exit Sub
col = find_rg.Column + 8
Mou3addaL = Val(First_sheet.Cells(8, col)) / 2
m = 4: k = 1
 For I = 10 To last_Clas
  If First_sheet.Cells(I, col) < Mou3addaL And _
     First_sheet.Cells(I, 4) = Mal_Femal Then
        If m Mod 19 = 0 Then m = m + 4: k = 1
          With Second_sheet.Cells(m, 2)
            .Value = k
            .Offset(, 1) = First_sheet.Cells(I, 3)
            .Offset(, 2) = First_sheet.Cells(I, 6)
          End With
     m = m + 1: k = k + 1
   End If
Next
  Application.EnableEvents = True
End Sub


الملف (نموذج)

 
24-11-2020 06:39 صباحا
icon حساب الحجم الساعي | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 استبدل في الكود 
    Mins  بـــ  دقيقة
    Hours   بــ ساعة
23-11-2020 09:31 مساء
icon حساب الحجم الساعي | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 العدد 20.25 يمثل 20 ساعة و 25% من الساعة اي ربع ساعة اي 15 دقيقة و هذا ما يدرجه الكود
تعديل الكود

Sub Three_Of_Four()
  Dim i%, RG As Range
  Dim D As Object
  Dim m%

Range("D17").Resize(, 10).ClearContents
Range("G18").ClearContents

  Set RG = Range("C11:M15")
  Set D = CreateObject("Scripting.Dictionary")
  

For i = 1 To RG.Cells.Count
  If RG.Cells(i) <> 0 Then
 m = m + 1
 D(RG.Cells(i).Value) = ""
   End If
Next
If D.Count Then
Range("D17").Resize(, D.Count) = D.keys
Range("G18") = (m * 0.75) / 24
Range("G18").NumberFormat = "hh ""Hours ,"" m ""Mins"""
End If
End Sub

الملف من جديد
23-11-2020 06:34 مساء
icon حساب الحجم الساعي | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 هذه لم افهمها (الحجم الساعي للأستاد)
لكن اتوقع عدد الحصص لكل صف
جرب هذا الكود

Option Explicit

Sub calclate()
  Dim i%, RG As Range
  Dim D As Object
   

Range("D17").Resize(, 10).ClearContents
Range("G18").Resize(, 7).ClearContents

  Set RG = Range("C11:M15")
  Set D = CreateObject("Scripting.Dictionary")
  

For i = 1 To RG.Cells.Count
  If RG.Cells(i) <> 0 Then

   D(RG.Cells(i).Value) = _
   RG.Cells(i).Value & " : " & Application.CountIf(RG, RG.Cells(i)) & " حصة "
   End If
Next
If D.Count Then
 Range("D17").Resize(, D.Count) = D.keys
 Range("G18").Resize(, D.Count) = D.Items
End If
End Sub

الملف مرفق
23-11-2020 02:35 مساء
icon استيراد بيانات من ملف مغلق دون فتحه | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 هناك مشاركة بنفس الموضوع كتبتها يوم امس
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
22-11-2020 11:09 مساء
icon مطابقة الاسم بين الملفين ثم ترحيل الدرجة | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 جرب هذا الأمر
العمل في الملف Moutab
الكود يعمل حتى ولا كان الملف الثاني مغلقاً
المهم ان يكون الملفان في نفس الــ Folder

Option Explicit
Sub fINd_Please()
Dim mPath$
Dim F_Name
If UCase(ActiveSheet.Name) <> "A_SUIVRE" Then Exit Sub
mPath = ThisWorkbook.Path & ""
F_Name = mPath & "[Choise.xlsx]"
F_Name = F_Name & "Sheet1'!$A$2:$B$100"
Range("z4").Resize(15, 2).ClearContents
Range("Z4").Resize(15, 2).FormulaArray = "='" & F_Name

With Range("O5:O19")
.ClearContents
.Formula = _
"=IFERROR(INDEX($AA$4:$AA$18,MATCH(B5,$Z$4:$Z$18,2)),"""")"
 .Value = .Value
End With
Range("z4").Resize(15, 2).ClearContents

End Sub


 
21-11-2020 11:20 صباحا
icon عكس بيانات الاعمدة | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 بالنسبة لعكس الأعمدة يمكن الاستعانه بهذا الملف(معادلة واحدة تسحب يساراً و نزولاً)

 
20-11-2020 06:21 مساء
icon كود طباعة الشهادات | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 

1-تصغير الملف الى 20 - 40 اسم لا أكثر

تختار الأرقام من الخليتين B1 و  B2 (في حال الخطأ الماكرو ياخذ الأرقام من 1 الى عدد الطلاب)

2- في حال تريد طالباً واحداَ تكرر رقمه في B1 و  B2    مثلاً نريد الطالب رقم 5 نضع  5=B1 و  5=B2

يوجد صفحة مخفية لادراج الجداول (عدم المس بها لحسن سير عمل الماكرو)

جرب هذا الملف


Dim Mn%, Mx%, LR, k%, t%, i%
Dim ValA, ValB
Dim xx1%, xx2%
Rem Created By Salim On 20/11/2020
Sub CopY_rg(rg As Range, Where%)
rg.Copy
Saf.Range("A" & Where).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End Sub
'++++++++++++++++++++++++++++++++
Sub fil_Rg()
Rem Created By Salim  On 20/11/2020
LR = Fat.Cells(Rows.Count, 3).End(3).Row
If LR < 10 Then Exit Sub
xx1 = Val(Fat.Range("B1"))
xx2 = Val(Fat.Range("B2"))
ValA = IIf(xx1 <= 0, 1, Int(xx1))
ValB = IIf(xx2 <= 0, LR - 9, Int(xx2))

If ValA > LR - 9 Then ValA = 1
If ValB > LR - 9 Then ValB = LR - 9
Mn = Application.Min(ValA, ValB)
Mx = Application.Max(ValA, ValB)
Fat.Range("B1") = Mn: Fat.Range("B2") = Mx
t = Fat.Range("B2") - Fat.Range("B1") + 1
k = 1
Saf.Cells.Clear
For i = 1 To t
 Call CopY_rg(Source.Range("SPES_RG"), k)
 k = k + 18
 Next
 Saf.Rows.AutoFit
End Sub
'++++++++++++++++++++++++++++++++++
Sub Get_certificates()
Rem Created By Salim  On 20/11/2020
fil_Rg
Dim Ro1%, Ro2%, Pos%
Dim y%, n%
Dim A1, A2, A3
A1 = Application.Transpose(Source.Range("Q1:AA1"))
A1 = Application.Transpose(A1)
A2 = Application.Transpose(Source.Range("Q2:AA2"))
A2 = Application.Transpose(A2)
A3 = Application.Transpose(Source.Range("Q3:AA3"))
A3 = Application.Transpose(A3)
Pos = 8
Ro1 = Fat.Range("B1") + 9
Ro2 = Fat.Range("B2") + 9
 For y = Ro1 To Ro2
   Saf.Cells(Pos - 6, 3) = Fat.Cells(y, 3)
 For n = LBound(A1) To UBound(A1)
  If Saf.Cells(Pos, 1) = "" Then Exit For
      Saf.Cells(Pos, 3).Offset(, n - 1) = _
         Fat.Cells(y, A1(n))
      Saf.Cells(Pos, 3).Offset(1, n - 1) = _
         Fat.Cells(y, A2(n))
      Saf.Cells(Pos, 3).Offset(2, n - 1) = _
         Fat.Cells(y, A3(n))
  Next n
  Pos = Pos + 18
 Next y
  Saf.PageSetup.PrintArea = Saf.Range("a1") _
 .Resize(Pos - 10, 14).Address
End Sub

الملف مرفق
 
19-11-2020 10:00 صباحا
icon إظهار نتيجة معينة فقط وإخفاء باقي النتائج | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 
نفس المعادلة لكن تكتب في H1  الكلمة التي لا تريدها
في حال كانت H1 فارغة او يوجد فيها كلمة غير هذه الكلمات الثلاث تحصل على كل شيء
18-11-2020 08:22 مساء
icon إظهار نتيجة معينة فقط وإخفاء باقي النتائج | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 جرب هذا الملف

Option Explicit

Sub Hide_rows()
Dim i%
 Show_all
 For i = 2 To Range("A1").CurrentRegion.Rows.Count
  If Cells(i, 3).Value = Cells(1, "H") Then
   Cells(i, 1).EntireRow.Hidden = -1
  End If
 Next
End Sub
'+++++++++++++++++++++++
Sub Show_all()
 Range("A1").CurrentRegion.EntireRow.Hidden = 0
End Sub

الملف مرفق (عدد 2 ) الاول كود والثاني معادلة
16-11-2020 11:52 مساء
icon إستخراج قائمة غير مكررة من الأسماء | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 [quote=محمد أبو عبدو]
أخي أتمنى أني قد أجبت على سؤالك
لم أتمكن من رفع الملف، لكن جرب هذا الكود:

صديقي محمد
الكود الذي رفعته جيد جداً لكن عندي ملاحظات
1- لا ضرورة لهذا الكم الهائل من الأوامر  Select & Copy
      التي ترهق البرنامج دون  جدوى لاننا نستطيع ان ننسخ
      (Copy)اي  Range دون الانتقال الى الـــ Sheet التي تحتويه ثم             نعمل  له Select كي ننسخه
2- اذا كنت تريد استعمل الـــ   RemoveDuplicates هذا الكود
     الذي لا يحتوي على اي أمر  Select & Copy أو Paste

Sub find_Uniq()
    Dim SH1 As Worksheet, SH2 As Worksheet
    Dim L1%, L2%

    Set SH1 = Sheets("Sheet1")
    Set SH2 = Sheets("Sheet2")
    L1 = SH1.Cells(Rows.Count, 1).End(3).Row
    L2 = SH2.Cells(Rows.Count, 1).End(3).Row
  With SH2
    .Range("A2:A" & L2).ClearContents
    .Range("A2").Resize(L1).Value = _
      SH1.Range("A1").Resize(L1).Value
    .Range("A2").Resize(L1).RemoveDuplicates _
    1, Header:=2
  End With
End Sub


 
16-11-2020 09:25 مساء
icon إستخراج قائمة غير مكررة من الأسماء | الكاتب :salim |المنتدى: اكسيل اسئله واجابات
 جرب هذا الكود

Sub find_Uniq()
    Dim SH1 As Worksheet, SH2 As Worksheet
    Dim L1%, L2%, K%
    Dim Obj As Object

    Set SH1 = Sheets("Sheet1")
    Set SH2 = Sheets("Sheet2")
    Set Obj = CreateObject("Scripting.Dictionary")

L1 = SH1.Cells(Rows.Count, 1).End(3).Row
L2 = SH2.Cells(Rows.Count, 1).End(3).Row

    If L2 > 1 Then
     SH2.Range("A1").CurrentRegion.Offset(1). _
     Resize(L2 - 1).ClearContents
    End If
K = 1

Do Until K = L1 + 1
 If SH1.Cells(K, 1) <> vbNullString Then
    Obj(SH1.Cells(K, 1).Value) = vbNullString
 End If
 K = K + 1
Loop
 
 If Obj.Count Then
   SH2.Cells(2, 1).Resize(Obj.Count).Value = _
   Application.Transpose(Obj.keys)
 End If
End Sub

الملف مرفق

الصفحة 1 من 60 < 1 2 3 4 60 > الأخيرة »





الساعة الآن 01:06 صباحا

أعلن هنا
أعلن هنا
أعلن هنا