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

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


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





مدموج :تسريع الكود

السلام عليكم كود الاستاذ حسونه العزيز مشكوره جهوده، محتاج تسريع لكود البحث في التكست ١ في حال كانت الاسماء تزيد عن ١٠٠٠٠ ..



07-01-2021 04:34 صباحا
ابو طيبه
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 31-08-2019
رقم العضوية : 14499
المشاركات : 233
الجنس : ذكر
يتابعهم : 7
يتابعونه : 1
قوة السمعة : 290
 offline 

السلام عليكم كود الاستاذ حسونه العزيز مشكوره جهوده، محتاج تسريع لكود البحث في التكست ١ في حال كانت الاسماء تزيد عن ١٠٠٠٠ اسم وكذلك تسريع كود التسجيل.
كما في الملف مع جزيلا الشكر الموضوع مدموج من مواضيع متعدّدة
 
 
  نموذج الملف.xlsm   تحميل xlsm مرات التحميل :(11)
الحجم :(365.477) KB


07-01-2021 08:38 صباحا
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مدموج :تسريع الكود
جرب هذا الملف الذي لا يعتمد على الحلقات التكرارية من 1 الى 10000
بل يستعمل الدالة الرائعة FIND التي تضع يدها مباشرة على الخلية المطلوبة لمعرفة رقم الصف لهذه الخلية

Option Explicit
Dim SH2 As Worksheet, SH1 As Worksheet
Dim I As Long, RO As Long, WSLR As Long
Dim SHLR As Long, res As Long, SS As Long
Dim C As Range, K As Integer, MOT
Dim f_RG As Range, RO1%, RO2%

Private Sub UserForm_Initialize()
    Set SH1 = ThisWorkbook.Worksheets("ورقة1")
    Set SH2 = ThisWorkbook.Worksheets("ورقة2")
    WSLR = SH1.Cells(Rows.Count, 1).End(xlUp).Row
End Sub
'++++++++++++++++++++++++++++++++++++++++++
Private Sub TextBox1_Change()
WSLR = SH2.Cells(Rows.Count, 1).End(xlUp).Row

MOT = "*" & TextBox1.Value & "*"
If Len(MOT) <= 2 Then Exit Sub
If Me.ListBox1.ListIndex >= 0 Then Exit Sub
    With Me.ListBox1
        .Clear
        .ColumnCount = 4
     Set f_RG = SH2.Range("B1:B" & WSLR).Find(MOT, LOOKAT:=1)
      If Not f_RG Is Nothing Then
        RO1 = f_RG.Row: RO2 = RO1
        Do
         .AddItem
         For K = 0 To .ColumnCount - 1
         .List(.ListCount - 1, K) = SH2.Cells(RO2, 5 - K).Value
         Next
            Set f_RG = SH2.Range("B1:B" & WSLR).FindNext(f_RG)
            RO2 = f_RG.Row
            If RO2 = RO1 Then Exit Do
        Loop
      End If
    End With
End Sub
'++++++++++++++++++++++++++++++++++++++++++

Private Sub CommandButton1_Click()
    SHLR = SH1.Cells(Rows.Count, 2).End(xlUp).Row + 1
    With SH1.Range("B" & SHLR)
     .Value = TextBox1.Value: TextBox1 = ""
     .Offset(0, 1) = TextBox2.Value: TextBox2 = ""
     .Offset(0, 2) = _
      IIf(OptionButton1 = True, OptionButton1.Caption, OptionButton2.Caption)
     .Offset(0, 3) = TextBox4.Value
     TextBox4 = ""
    End With
    ListBox1.Clear

End Sub
'++++++++++++++++++++++++++++++++++++++++++

Private Sub ListBox1_Click()
 Dim X
 X = Me.ListBox1.ListIndex
 If X < 0 Then Exit Sub
   TextBox2.Text = Me.ListBox1.List(X, 2)
   Select Case True
      Case Me.ListBox1.List(X, 1) = "ابتدائي"
         OptionButton2 = True: OptionButton1 = False
      Case Else
         OptionButton2 = False: OptionButton1 = True
   End Select

   TextBox4.Text = Me.ListBox1.List(X, 0)
   TextBox1.Value = Me.ListBox1.List(X, 3)
Me.ListBox1.ListIndex = -1
End Sub

الملف مرفق
 
 
 
  AB_TIBA.xlsm   تحميل xlsm مرات التحميل :(14)
الحجم :(373.997) KB


12-01-2021 09:24 صباحا
مشاهدة مشاركة منفردة [2]
ابو طيبه
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 31-08-2019
رقم العضوية : 14499
المشاركات : 233
الجنس : ذكر
يتابعهم : 7
يتابعونه : 1
قوة السمعة : 290
 offline 
look/images/icons/i1.gif مدموج :تسريع الكود
السلام عليكم هل يمكن اضافة هذه الاكواد لتسريع
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

كود البحث للاستاذ سليم المحترم
Private Sub TextBox1_Change()
WSLR = WS.Cells(Rows.Count, 1).End(xlUp).Row
MOT = "*" & TextBox1.Value & "*"
If Len(MOT) <= 2 Then Exit Sub
If Me.ListBox1.ListIndex >= 0 Then Exit Sub
    With Me.ListBox1
        .Clear
        .ColumnCount = 4
     Set f_RG = WS.Range("B1:B" & WSLR).Find(MOT, LOOKAT:=1)
      If Not f_RG Is Nothing Then
        RO1 = f_RG.Row: RO2 = RO1
        Do
         .AddItem
         For K = 0 To .ColumnCount - 1
         .List(.ListCount - 1, K) = WS.Cells(RO2, 5 - K).Value
         Next
            Set f_RG = WS.Range("B1:B" & WSLR).FindNext(f_RG)
            RO2 = f_RG.Row
            If RO2 = RO1 Then Exit Do
        Loop
      End If
    End With
End Sub

كود الاستاذ حسونة المحترم
Private Sub TextBox1_Change()
WSLR = WS.Cells(Rows.Count, 1).End(xlUp).Row
K = 0
On Error Resume Next
    With Me.ListBox1
        .Clear
        .ColumnCount = 4
        For Each C In WS.Range("B2:B" & WSLR)
            If TextBox1.Value <> "" Then
                If C Like "*" & TextBox1.Value & "*" Then
                    .AddItem
                    .List(K, 0) = WS.Cells(C.Row, 5).Value
                    .List(K, 1) = WS.Cells(C.Row, 4).Value
                    .List(K, 2) = WS.Cells(C.Row, 3).Value
                    .List(K, 3) = WS.Cells(C.Row, 2).Value
                    .List(K, 4) = C.Row
                    K = K + 1
                End If
            End If
        Next C
    End With
End Sub




الكلمات الدلالية
تسريع ، الكود ،


 










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

الساعة الآن 08:31 صباحا