logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
Hatem Eissa hassona229-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة اكسيل مشاريع جاهزه



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





01-12-2017 04:06 مساءً
السلام عليك ورحمة الله وبركاته
اليوم سوف نحاول معالجةموضوع ثقل تنفيذ كود إخفاء الصفوف بشرط معين.
لقد لاحظة من خلال التجربة البسيطة أنه هناك بعض أجهزة الحاسوب الضعيفة لا تتحمل كود إخفاء الصفوف الذي هو كالتالي:
CODE
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim rng As Range
Dim cell As Range
Set rng = Range("b7:b99")
For Each cell In rng
If cell.Value = 0 Or cell.Value = "" Then
cell.EntireRow.Hidden = True
End If
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

ومن خلال البحث وجدت أنه لتجاوز هذه المشكلة يجب تنفيذ هذا الكود على اليوزر فورم وليس ورقة العمل، كيف ذلك؟ هذا ما سنتناوله في موضوعنا اليوم.
الفكرة هي البحث عن البيانات التي نريدها من ورقة العمل ثم عرضها في ليس بوكس ثم نسخها على ورقة أخرى!!!!؟
هنا البعض يستغرب ويقول من النظرة الأولى لهذه الفكرة أن هذا الكود سوف يأخذ وقت أكثر من فلترة البيانات على الورقة نفسها. لكن أثبتت تجربتي المتواضعة على بعض الحواسب الضعيفة أن كود الإخفاء الذي ذكرناه سابقا يأخذ حوالي 41 ثانية ليكمل إجراء الإخفاء على بيانات متكونة من 92 سطر. لكن مع العمل الذي سوف نقوم به لا يتجاوز أجزاء من الثانية.
أما الحواسيب الجيدة تقريبا لا يوجد فرق بين الكودين.
على بركة الله نشرع بمثال تطبيقي
فرضا عندي بيانات في ورقة عمل كالتي موضحة في الصورة والتي تحتوي على 92 سطر من البيانات مثلا
NDUxODc3MQ8989%D9%88%D8%B1%D9%82%D8%A9%20%D8%A8%D9%8A%D8%A7%D9%86%D8%AA

أريد أن أطبع الأسطر التي فيها قيمة العود الموجود في الصورة السابقة(NT) أكبر من 0 أو أكبر من الفراغ. طبعا هنا نستطيع إستعمال كود إخفاء الصفوف الذي ذكرناه أولا لكن كما قلنا سابقا سوف نواجه مشاكل في بعض الحواسب وليس كلها.
الحل هو
أولا نضيف ورقة ثانية في الملف كماهي موضحة في الصورة
NDg1NDgx%D9%88%D8%B1%D9%82%D8%A9%20%D8%A8%D9%8A%D8%A7%D9%86%D8%A7%D8%AA2
ثم نقوم بإدراج يوزر فورم فيه ليست بوكس و زر للطباعة كما هو موضح في الشكل التالي
MTcwNDg3MQ1111%D9%8A%D9%88%D8%B2%D8%B1%20%D9%81%D9%88%D8%B1%D9%85
نضغ على اليوزر فورم دبل كليك ونضع الكود التالي
CODE
Private Sub UserForm_Activate()
 'هذا الجزأ خاص بمسح البيانات الموجودة في الورقة data2
'وكذلك لتقسيم الليس بوكس
Sheets("data2").Activate

Range("A7:K99").Select
    Selection.ClearContents
    Sheets("data").Activate

ListBox1.ColumnWidths = "68;68;68;68;68;68;68;68;68;68"         'Column Widths Of Listbox
ListBox1.ColumnCount = 10
ListBox1.Clear
'==================================
'هذا  الجزأ خاص بتعبأة الليست بوكس بالبيانات المطلوبة
Dim i As Long
lastrow = Sheets("DATA2").Cells(Rows.Count, 1).End(xlUp).Row
For i = 7 To 99
If Cells(i, 2).Value <> 0 Then
    Cells(i, 1).Select
Range(ActiveCell, ActiveCell.Offset(0, 10)).Select
 With UserForm2.ListBox1
            .AddItem
            .List(.ListCount - 1, 0) = ActiveSheet.Cells(i, 1).Text
            .List(.ListCount - 1, 1) = ActiveSheet.Cells(i, 2).Value
            .List(.ListCount - 1, 2) = ActiveSheet.Cells(i, 3).Value
            .List(.ListCount - 1, 3) = ActiveSheet.Cells(i, 4).Value
            .List(.ListCount - 1, 4) = ActiveSheet.Cells(i, 5).Value
            .List(.ListCount - 1, 5) = ActiveSheet.Cells(i, 6).Value
            .List(.ListCount - 1, 6) = ActiveSheet.Cells(i, 7).Value
            .List(.ListCount - 1, 7) = ActiveSheet.Cells(i, 8).Value
            .List(.ListCount - 1, 8) = ActiveSheet.Cells(i, 9).Value
            .List(.ListCount - 1, 9) = ActiveSheet.Cells(i, 10).Value
                    
        End With
        
      End If
      Next
 Application.CutCopyMode = False
End Sub

وهذا الكود هو لمسح البيانات من الورقة 2 وتعبيئة الليست بوكس بالبيانات التي تحقق الشرط المعلن عنه في الكود من الورقة 1
ثم نضغط دبل كلك على زر الطباعة وندر الكود التالي
CODE
 'هذا الجزأ خاص بتحديد كل البيانات الموجودة داخل الليست بوكس
 Dim r As Long
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ListBox1.ListIndex = -1

ListBox1.MultiSelect = fmMultiSelectMulti
    For r = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(r) = True
    Next r
   
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
 '---------------------------------------------------------------------------
 ' أما هذا الجزء فهو لنسخ البيانات الموجودة داخل اليست بوكس على الورقة الثانية
 Dim Litem As Long, LbRows As Long, LbCols As Long
 Dim bu As Boolean
 Dim Lbloop As Long, Lbcopy As Long
 
 LbRows = ListBox1.ListCount - 1
 LbCols = ListBox1.ColumnCount - 1
   
    For Litem = 0 To LbRows
    If ListBox1.Selected(Litem) = True Then
          bu = True
          Exit For
    End If
    Next
    If bu = True Then
    With Sheets("DATA2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      
            For Litem = 0 To LbRows
                If ListBox1.Selected(Litem) = True Then 'Row selected
                  ''Increment variable for row transfer range
                  Lbcopy = Lbcopy + 1
            For Lbloop = 0 To LbCols
                  ''Transfer selected row to relevant row of transfer range
            .Cells(Lbcopy, Lbloop + 1) = ListBox1.List(Litem, Lbloop)
                       
           Next Lbloop
                End If
            Next
            For m = 0 To LbCols
                With Sheets("DATA2").Cells(Rows.Count, 1).End(xlUp).Offset(0, m).Borders(xlEdgeBottom)
                End With
Next
        End With
    Else
         MsgBox "Rinen n'a choisi", vbCritical
         Exit Sub
    End If
     Sheets("data2").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

ActiveSheet.Range("a1:k102").PrintOut
End Sub

وفي هذا الكود قمنا في الجزء الأول بتحديد كل البيانات الموجودة في الليست بوكس وفي الجزء الأخير قمنا بنسخ البيانات المحددة في اليست بوكس على الورقة2 ثم طباعتها
وخلاصة القول هي أنه إذا أردنا إنشاء برنامج سريع من ناحية التنفيذ نحاول أن ننفذ الأوامر على اليوزر فورم مثل تصفية البيانات
أرجوا من الله أن يكون هذا الموضوع فيه فائدة لمن يعانون من ضعف الأجهزة وغيرهم
هذا مثال تطبيقي على الموضوع
attachمثال تطبيقي.rar
 
  ورقة بيانت.png   تحميل png ورقة بيانت.png مرات التحميل :(2)
الحجم :(82.004) KB
  يوزر فورم.png   تحميل png يوزر فورم.png مرات التحميل :(5)
الحجم :(54.689) KB
  ورقة بيانات2.png   تحميل png ورقة بيانات2.png مرات التحميل :(2)
الحجم :(66.986) KB
 
  مثال تطبيقي.rar   تحميل rar مرات التحميل :(52)
الحجم :(82.131) KB




توقيع :Kamel meraghni

<big> الحمد لله وكفى والصلاة والسلام على الحبيب المصطفى </big>


142

look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  01-12-2017 07:39 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 14
المشاركات : 1309
الدولة : مصر
الجنس :
تاريخ الميلاد : 4-7-1990
الدعوات : 59
قوة السمعة : 4570
الاعجاب : 0
موقعي : زيارة موقعي
صلى الله علية وسلم

بارك الله فيك عمل ممتاز وننتظر الميز



توقيع :محمود ابو الدهب
لى عظيم الشرف بالانضمام لهذا الصرح العظيم
وكم أتمنى من الله
ان يعيننى ويعلمنى من علمة الواسع فهو ولي ذالك وهو على كل شي قدير

تحياتى وتقدير للجميع  محمود ابوالدهب

look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  01-12-2017 08:16 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 107
الجنس :
تاريخ الميلاد : 23-10-1984
قوة السمعة : 754
الاعجاب : 2
وفيك بارك الله أخي تأكد أخي أن لن أبخل عليكم ماتعلمته وذلك كلما أتيحت لي الفرصة بأذن الله



توقيع :Kamel meraghni

<big> الحمد لله وكفى والصلاة والسلام على الحبيب المصطفى </big>


142

look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  01-12-2017 11:16 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10529
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36759
الاعجاب : 186
بارك الله فيك أخي الكريم كامل وجزاك الله خيراً
حاول استخدام اللغة العربية في الملفات المرفقة لتمام الاستفادة ..




look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  02-12-2017 08:01 صباحاً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1824
الجنس :
الدعوات : 21
قوة السمعة : 20048
الاعجاب : 12
موقعي : زيارة موقعي

جزاكم الله خيرا اخى الكريم 142




توقيع :الصقر

اخى العضو الكريم
اذا كنت ترى ان المنتدى مفيد لك
فكن سفيرا لنا بدعوة الاخرين للانضمام معنا
فالدال على الخير كفاعله


look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  02-12-2017 08:27 مساءً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 107
الجنس :
تاريخ الميلاد : 23-10-1984
قوة السمعة : 754
الاعجاب : 2
الشكر موصول اليكم أيضا لأني تلميذ لديكم
في الحقيقة ضيق الوقت هو الذي تركني انشر أجزاء بسيطة من برنامج صممته للشركة التي أعمل بها مع العلم أننا في الجزائر جل الاداراة تتعامل باللغة الفرنسية مع الاسف لكن سوف أحاول أن أشارك بمواضيع باللغة العربية في المستقبل وذلك كلما توفر قليل من اللوقت ان شاء الله.



توقيع :Kamel meraghni

<big> الحمد لله وكفى والصلاة والسلام على الحبيب المصطفى </big>


142

look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  03-01-2018 09:41 مساءً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 02-01-2018
رقم العضوية : 3234
المشاركات : 39
الجنس :
قوة السمعة : 46
الاعجاب : 0
جزاكم الله خيرا




look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  09-12-2018 03:42 مساءً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-11-2018
رقم العضوية : 9298
المشاركات : 119
الجنس :
تاريخ الميلاد : 27-6-1985
قوة السمعة : 110
الاعجاب : 0
جزاك الله خيرا




look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  31-03-2019 03:21 مساءً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس :
تاريخ الميلاد : 17-8-1981
قوة السمعة : 244
الاعجاب : 0
بارك الله فيك .............................................. وجزاك الله خيراً




look/images/icons/i1.gif نسخ البيانات من الليست بوكس
  31-03-2019 03:25 مساءً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10529
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36759
الاعجاب : 186
إخواني الكرام يرجى أن تكون الردود لائقة




اضافة رد جديد اضافة موضوع جديد



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
دوره متكامله في الأكسس من خلال مشروع عملي شرح و تحليل قاعدة البيانات بكار للأبد
34 6624 alilo
كود بحث مطاطي بأي جزء من البيانات علي بطيخ سالم
11 2007 star
تموذج ترحيل وبحث وتعديل على البيانات مالك ماريه
147 12699 sharawee707
ترحيل بيانات من خلايا مختلفه من ملفات الى ملف واحد مع كتابة الملاحظات التى تخص ترحيل البيانات Lotfy
7 290 YasserKhalil
مشكلة كود حفظ تعديل البيانات في اليوزرفورم شبل
1 442 شبل

الكلمات الدلالية
الليست ، بوكس ، البيانات ،









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

الساعة الآن 11:03 PM