تصفية البيانات بالكود

[أبو عبد الله _]

في المرفق يوجد بيانات في ورقة عمل المخزون وتتكرر بعض البيانات فيها ارغب في كود ينقل البيانات إلى ورقة العمل البيانات بدون تكرار  وبدون فراغات 

حاولت استخدام دالة index و match مع countif ( معادلة صفيف) لكن حجم الملف يكبر و يحدث بطء في التنفيذ اذا تم تغيير العديد من البيانات 

 

تصفية بيانات المخزن.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

تفضل اخي

Sub SansDoublons()
  Set f = Sheets("المخزن")
  Set M = Sheets("البيانات")
   Application.ScreenUpdating = False
  Set réf = CreateObject("Scripting.Dictionary")
  A = Range(f.[C3], f.[C65000].End(xlUp)).Value
  For Each c In A
     réf(c) = ""
  Next c
  Set dest = M.Range("C3")
  dest.Resize(réf.Count, 1) = Application.Transpose(réf.keys)
 ' ترتيب ابجدي
  dest.Resize(réf.Count, 1).Sort Key1:=dest, Order1:=xlAscending
  Set réf = Nothing
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'في حالة الرغبة بوضع الكود في حدث الشيت
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Set f = Sheets("المخزن")
Set M = Sheets("البيانات")
  Set réf = CreateObject("Scripting.Dictionary")
  A = Range(f.[C3], f.[C65000].End(xlUp)).Value
  For Each c In A
     réf(c) = ""
  Next c
  Set dest = M.Range("C3")
  dest.Resize(réf.Count, 1) = Application.Transpose(réf.keys)
  dest.Resize(réf.Count, 1).Sort Key1:=dest, Order1:=xlAscending
  Set réf = Nothing
  End If
End Sub

 

V1_تصفية بيانات المخزن .xlsm

[أبو عبد الله _]

جزاكم الله خيراً استاذ محمد 

ويعمل بكفاءة 

لكن عند إلغاء الترتيب الابجدي يظهر خليه فارغة في المنتصف هل لها حل إذا التعديل يحتاج وقت فالكود الحالي يكفي 

❤️❤️

تم تعديل فبراير 13, 2023 بواسطه أبو عبد الله _

[أبو عبد الله _]

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

كنت افكر في هذ الامر الترحيل التلقائي من خلال حدث الورقة 

اولا تم وضع الكود في حدث ورقة العمل المخزن لكن عند ادخال البيانات يظهر رسالة خطأ  عند السطر for each c in a

ثانيا عند محاولة الكتابة في الخلية C3في المخزون او عند الضغط عليها لاول مرة 

تظهر كلمة اسم الصنف في الخلية c3في ورقة البيانات

هناك امر غريب عندما قمت باستدعاء الكود من موديول ١ عن طريق call في حدث الورقة فانه يعمل 

### *** ارغب في إضافة بسيطة وهو عند حذف البيانات من المخزن يتم حذفها من ورقة عمل البيانات ( جميع البيانات) 

الله يعطيك العافية

تم تعديل فبراير 14, 2023 بواسطه أبو عبد الله _

[محمد هشام.]

ضعه بحدث شيت المخزن بهذه الطريقة اخي
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Set f = Sheet2 
Set m = Sheet1 
Application.ScreenUpdating = False
f.Activate
Set MonDico = CreateObject("Scripting.Dictionary")
 For Each a In f.Range("C3", [C65000].End(xlUp))
   If a <> "" Then MonDico(a.Value) = ""
 Next a

  With m.Range("C3:C65000")
   .ClearContents
   .Resize(MonDico.Count) = Application.Transpose(MonDico.keys)
  End With

End Sub

 

 

V3_تصفية بيانات المخزن (1).xlsm

[أبو عبد الله _]

الله يعطيك الف عافية

ما قصرت

جزاكم الله خيراً 

🌹♥️🌹

[أبو عبد الله _]

استاذ محمد 

الكود يعمل بكفاءة ماشاء الله 

لكن ارغب في تعديل بسيط

لاحظت ان الكود يعمل عند الضغط في اي خلية او ادخال بيانات في اي خلية

ما اريد هو ان يتم تنفيذ الكود فقط عند ادخال بيانات في العمود C او D فقط

وتحياتي لك

[محمد هشام.]

نعم اخي يمكنك دالك باضافة بسيطة للكود ليتم تنفيده فقط عند التغيير في عمود  C

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
 Set f = Sheet2 's("المخزن")
Set m = Sheet1 's("البيانات")
Application.ScreenUpdating = False
Set MonDico = CreateObject("Scripting.Dictionary")
 For Each a In f.Range("C3", [C65000].End(xlUp))
   If a <> "" Then MonDico(a.Value) = ""
 Next a

  With m.Range("C3:C65000")
   .ClearContents
   .Resize(MonDico.Count) = Application.Transpose(MonDico.keys)
  End With
End If
End Sub

 

[أبو عبد الله _]

🌹🌹🌹🌹🌹

[أبو عبد الله _]

استاذ محمد

هل ممكن تساعدني في الموضوع في الرابط ادناه 

حيث ان الاستاذ lionheart قام بمحاولة معي وجزاه الله خيرا لكن هناك صعوبة في التواصل معه من حيث اللغة 

وحاولت ارسال رسالة لك لكن يظهر ان الحد اليومي صفر رسالة