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



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





نسخ البيانات من الليست بوكس

السلام عليك ورحمة الله وبركاته اليوم سوف نحاول معالجةموضوع ثقل تنفيذ كود إخفاء الصفوف بشرط معين. لقد لاحظة من خلال التجر ..



01-12-2017 04:06 مساء
Kamel meraghni
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 101
الجنس : ذكر
تاريخ الميلاد : 23-10-1984
يتابعهم : 7
يتابعونه : 6
قوة السمعة : 578
الاعجاب : 128
 offline 

السلام عليك ورحمة الله وبركاته
اليوم سوف نحاول معالجةموضوع ثقل تنفيذ كود إخفاء الصفوف بشرط معين.
لقد لاحظة من خلال التجربة البسيطة أنه هناك بعض أجهزة الحاسوب الضعيفة لا تتحمل كود إخفاء الصفوف الذي هو كالتالي:
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
نضغ على اليوزر فورم دبل كليك ونضع الكود التالي
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
ثم نضغط دبل كلك على زر الطباعة وندر الكود التالي
 'هذا الجزأ خاص بتحديد كل البيانات الموجودة داخل الليست بوكس
 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 ثم طباعتها
وخلاصة القول هي أنه إذا أردنا إنشاء برنامج سريع من ناحية التنفيذ نحاول أن ننفذ الأوامر على اليوزر فورم مثل تصفية البيانات
أرجوا من الله أن يكون هذا الموضوع فيه فائدة لمن يعانون من ضعف الأجهزة وغيرهم
هذا مثال تطبيقي على الموضوع
لرؤية الروابط والمرفقات عليك الرد على الموضوع




لرؤية الروابط والمرفقات عليك الرد على الموضوع


أثارت هذه المشاركة إعجاب: malik، الصقر، atc_340،


توقيع :Kamel meraghni

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



142




01-12-2017 07:39 مساء
مشاهدة مشاركة منفردة [1]
محمود ابو الدهب
menu_open
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 14
المشاركات : 673
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 4-7-1990
الدعوات : 56
يتابعهم : 6
يتابعونه : 140
قوة السمعة : 2382
الاعجاب : 859
 offline 
look/images/icons/i1.gif نسخ البيانات من الليست بوكس
صلى الله علية وسلم 

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

أثارت هذه المشاركة إعجاب: Kamel meraghni،


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

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


01-12-2017 08:16 مساء
مشاهدة مشاركة منفردة [2]
Kamel meraghni
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 101
الجنس : ذكر
تاريخ الميلاد : 23-10-1984
يتابعهم : 7
يتابعونه : 6
قوة السمعة : 578
الاعجاب : 128
 offline 
look/images/icons/i1.gif نسخ البيانات من الليست بوكس
وفيك بارك الله أخي تأكد أخي أن لن أبخل عليكم ماتعلمته وذلك كلما أتيحت لي الفرصة بأذن الله

أثارت هذه المشاركة إعجاب: elskary2010،


توقيع :Kamel meraghni

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



142



01-12-2017 11:16 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 4651
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 11
يتابعهم : 0
يتابعونه : 318
قوة السمعة : 13375
الاعجاب : 4949
 offline 
look/images/icons/i1.gif نسخ البيانات من الليست بوكس
بارك الله فيك أخي الكريم كامل وجزاك الله خيراً
حاول استخدام اللغة العربية في الملفات المرفقة لتمام الاستفادة .. 

أثارت هذه المشاركة إعجاب: Kamel meraghni،




02-12-2017 08:01 صباحا
مشاهدة مشاركة منفردة [4]
الصقر
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1410
الجنس : ذكر
الدعوات : 12
يتابعهم : 0
يتابعونه : 359
قوة السمعة : 11267
الاعجاب : 2791
 offline 
look/images/icons/i1.gif نسخ البيانات من الليست بوكس

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



أثارت هذه المشاركة إعجاب: Kamel meraghni،




02-12-2017 08:27 مساء
مشاهدة مشاركة منفردة [5]
Kamel meraghni
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 101
الجنس : ذكر
تاريخ الميلاد : 23-10-1984
يتابعهم : 7
يتابعونه : 6
قوة السمعة : 578
الاعجاب : 128
 offline 
look/images/icons/i1.gif نسخ البيانات من الليست بوكس
الشكر موصول اليكم أيضا لأني تلميذ لديكم
في الحقيقة ضيق الوقت هو الذي تركني انشر أجزاء بسيطة من برنامج صممته للشركة التي أعمل  بها مع العلم أننا في الجزائر جل الاداراة تتعامل باللغة الفرنسية مع الاسف لكن سوف أحاول أن أشارك بمواضيع باللغة العربية في المستقبل  وذلك كلما توفر قليل من اللوقت ان شاء الله.
 

أثارت هذه المشاركة إعجاب: YasserKhalil،


توقيع :Kamel meraghni

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



142



03-01-2018 09:41 مساء
مشاهدة مشاركة منفردة [6]
atc_340
menu_open
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 02-01-2018
رقم العضوية : 3234
المشاركات : 7
الجنس : ذكر
يتابعهم : 0
يتابعونه : 1
قوة السمعة : 10
الاعجاب : 0
 offline 
look/images/icons/i1.gif نسخ البيانات من الليست بوكس
جزاكم الله خيرا
 






المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
استيراد بيانات من ملف خارجي محدد- ملف البيانات- نصر الإيمان
9 91 محمد الدسوقى
وضع سطر فارغ بعد مجموعة من البيانات khaled alborene
13 118 YasserKhalil
تعديل جديد على تقرير جلب البيانات عبدالله فتحى
7 90 ابونور
محاضرة جديدة - تابع الاسس العلمية فى قواعد البيانات - الاربعاء 4 ابريل 2018 عبدالجيد
5 365 elabass
انشطار البيانات في عمود لعدة أوراق عمل باستخدام التصفية المتقدمة YasserKhalil
15 321 مالك ماريه

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


 







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



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

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