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



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





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

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



01-12-2017 04:06 مساء
Kamel meraghni
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 97
الجنس : ذكر
تاريخ الميلاد : 23-10-1984
يتابعهم : 7
يتابعونه : 5
قوة السمعة : 528
الاعجاب : 114
 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 ثم طباعتها
وخلاصة القول هي أنه إذا أردنا إنشاء برنامج سريع من ناحية التنفيذ نحاول أن ننفذ الأوامر على اليوزر فورم مثل تصفية البيانات
أرجوا من الله أن يكون هذا الموضوع فيه فائدة لمن يعانون من ضعف الأجهزة وغيرهم
هذا مثال تطبيقي على الموضوع
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
  ورقة بيانت.png   تحميل png ورقة بيانت.png مرات التحميل :(1)
الحجم :(82.004) KB
  يوزر فورم.png   تحميل png يوزر فورم.png مرات التحميل :(3)
الحجم :(54.689) KB
  ورقة بيانات2.png   تحميل png ورقة بيانات2.png مرات التحميل :(1)
الحجم :(66.986) KB
 
  مثال تطبيقي.rar   تحميل rar مرات التحميل :(21)
الحجم :(82.131) KB


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


توقيع :Kamel meraghni

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



142




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

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

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


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

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


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

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


توقيع :Kamel meraghni

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



142



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

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




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

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



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




02-12-2017 08:27 مساء
مشاهدة مشاركة منفردة [5]
Kamel meraghni
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 182
المشاركات : 97
الجنس : ذكر
تاريخ الميلاد : 23-10-1984
يتابعهم : 7
يتابعونه : 5
قوة السمعة : 528
الاعجاب : 114
 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 نسخ البيانات من الليست بوكس
جزاكم الله خيرا
 






المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
بحث عن البيانات برقم التسلسل محمد النيل
10 116 Eslam Abdullah
مشكله عند مسح البيانات نصر الإيمان
3 32 YasserKhalil
تعديل كود ترحيل البيانات باستخدام المصفوفات مُعتز
11 93 YasserKhalil
طلب كود اترحيل البيانات المشروط khaled alborene
21 187 YasserKhalil
كود لجلب البيانات من ملفين للثالث بشرطين أو ثلاثة samycalls2020
18 213 YasserKhalil

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


 







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



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

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