ترحيل بيانات الى ورقة الجميع بدون تكرار

[مصطفى محمود مصطفى]

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

الاساتذة الافاضل جزاكم الله خيرا

توجد بيانات متغيرة في ورقة الترحيل اعتمادا على خلية

المطلوب ترحيل هذه البيانات عند الاختيار من الخلية وتتغير البيانات نضغط على ترحيل فترحل قيم فقط الى ورقة الجميع 

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

لكم وافر احترامي

ترحيل لورقة واحدة دون تكرار.xlsx

[مصطفى محمود مصطفى]

السلام عليكم

وجدت هذا الكود في المنتدى وغيرت به ليتناسب مع الملف 

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

وثانيا لما بيرحل البيانات يترك فراغ بين الترحيل والاخر

ارجو تعديله او كود اخر يفي بالغرض

ولكم وافر الاحترام

Sub ADD_QAID()
'If Range("H7") = False Then
'MsgBox "ÇáÞíÏ ãßÑÑ æ áÇ íãßä ÍÝÙÉ", , "ÎØÃÁ"
'Exit Sub
'End If
Dim TR, CC
TR = Application.CountA(Sheets("ÇáÌãíÚ").Range("C1:C55555")) + 5

    Range("C6:H1000").Copy
    Sheets("ÇáÌãíÚ").Range("C" & TR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


End Sub

ترحيل لورقة واحدة دون تكرار.xlsm

[سليم حاصبيا]

جرب هذا الملف

هناك  معادلة في الشيت   "data" العامود "I" (مخفي) لا يجب ان تمسح  لانها  تحدد   المكرر من غير المكرر (غير المكرر تعطيه رقم 1)

 على اساس هذا الرقم تتم الفلترة    (عند الضغط على الزر  Run من صفحة "data")

الفلتر يتعامل رأساً  مع الصفحة  "data"  و ينقل النتيجة الى الصفحة "Summary"

الكود

Option Explicit
Sub filter_More_critertias()
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
Dim S_sh As Worksheet: Set S_sh = Sheets("data")
Dim T_sh As Worksheet: Set T_sh = Sheets("Summary")
Dim My_Table As Range: Set My_Table = S_sh.Range("b5").CurrentRegion

T_sh.Range("b5").CurrentRegion.Clear
T_sh.Range("q6").Formula = "=data!I6=1"

My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q5:q6"), _
CopyToRange:=T_sh.Range("b5")

'===============================
 With T_sh
   .Range("q6").Clear
   .Columns("i").Clear
   .Sort.SortFields.Clear
   .Sort.SortFields.Add Key:=Range("H6") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "الاول,الثاني,الثالث", DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("B5").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    End With

    With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
    End With
End Sub

الملف مرفق

 

ترحيل لورقة واحدة Salim.xlsm

[Ali Mohamed Ali]

كود ممتاز استاذى سليم دائما مبدع

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

ارجو التنبيه من الأستاذ مصطفى اذا كان هناك لبس أوغلط

[مصطفى محمود مصطفى]

السلام عليكم

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

وكما تفضل الاستاذ علي محمد جزاه الله خيرا

الترحيل يكون من ورقة الترحيل وانا غيرت بالورقة ووضعت رقم 1 يدوي في العمود I وقام الكود بالترحيل

الكود ممتاز ورائع  لكن لي ملاحظتين بالاضافة لملاحظة الاستاذ علي

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

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

وفقكم الله وحفظكم وسدد خطاكم لما فيه خير الاسلام والمسلمين

لكم تحياتي ووافر احترامي

ترحيل لورقة واحدة Salim.xlsm

 

[سليم حاصبيا]

 اعتقد انه لا ضرورة للترحيل من صفحة الترحيل لان الكود يقوم بترحيل كل شيء و يقوم بترتيبها

بدل ان تقوم في كل مرة بالتبديل بين  (الاول  والثاني  والثالث) في صفحة الترحيل   ( اي اجراء حلقة تكرارية لتنفيذ ماكرو واحد 3 مرات متتالية)

اما صفحة الترحيل  اتركها لفرز البيانات

بعد تنفيذ الماكرو تستطيع ان تذهب الى صفحة Summary و تجري هناك عملية Remove duplicates

على كل الاعمدة ما عدا العامود الاول (حيث الترقيم) 

(يمكن تحرير ماكرو لهذا الغرض عند حذث Worksheet_Activate)  او بواسطة زر يوضع في هذه الصفحة يقوم بهذا العمل

الماكرو المطلوب

Sub Remove_Dup()
Sheets("Summary").Range("b5").CurrentRegion.RemoveDuplicates _
 Columns:=Array(2, 3, 4, 5, 6, 7), Header:=1
End Sub

 

[مصطفى محمود مصطفى]

السلام عليكم

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

ممتاز استاذنا العزيز الان بقي الترحيل تحت اخر صف لان البيانات ربما تستمر لسنة او عدة اشهر  فتضاف الكثير

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

ولكم كل الاحترام والتقدير

[ouadane]

السلام عليكم و رحمة الله و بركاته أحتاج مساعدة منكم يا خبراء الاعلام الالي عندي جدول به الاسم و اللقب في العمود الاول و تاريخ و مكان الميلاد في العمود الثاني و القسم في العمود الثالث و الصفة في العمود الرابع و يحوي الجدول على اكثر من 1200تلميذ اريد ان اجعل في صفحةاكسل اخرى (غير التي فيها الجدول) مختصر له بحيث اذا كتبت اسم و لقب التلميذ يظهر قسمه و تاريخ ميلاده و صفته

[سليم حاصبيا]

استبدل الماكرو الى هذا

Option Explicit
Sub filter_More_critertias()
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
    Dim laste_row, New_last_row%
Dim S_sh As Worksheet: Set S_sh = Sheets("data")
Dim T_sh As Worksheet: Set T_sh = Sheets("Summary")
Dim My_Table As Range: Set My_Table = S_sh.Range("b5").CurrentRegion
laste_row = T_sh.Cells(Rows.Count, 3).End(3).Row
If laste_row < 5 Then laste_row = 4
T_sh.Range("q6").Formula = "=data!I6=1"

My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q5:q6"), _
CopyToRange:=T_sh.Range("b" & laste_row + 1)

'===============================
 With T_sh
   .Range("q6").Clear
   .Columns("i").Clear
   .Sort.SortFields.Clear
   .Sort.SortFields.Add Key:=Range("H6") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "الاول,الثاني,الثالث", DataOption:=xlSortNormal
    With .Sort
        .SetRange Range("B5").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    '=======================
    End With
     Remove_Dup
     New_last_row% = T_sh.Cells(Rows.Count, 3).End(3).Row
     If Cells(New_last_row, 3) = "رقم الحساب" Then
     Cells(New_last_row, 3).EntireRow.Delete
     End If
     '=======================
      With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
      End With
  
End Sub
  '=======================
Sub Remove_Dup()
Sheets("Summary").Range("b5").CurrentRegion.RemoveDuplicates _
 Columns:=Array(2, 3, 4, 5, 6, 7), Header:=1
End Sub

الملف

Tarhil_Unique.xlsm

3 دقائق مضت, ouadane said:

السلام عليكم و رحمة الله و بركاته أحتاج مساعدة منكم يا خبراء الاعلام الالي عندي جدول به الاسم و اللقب في العمود الاول و تاريخ و مكان الميلاد في العمود الثاني و القسم في العمود الثالث و الصفة في العمود الرابع و يحوي الجدول على اكثر من 1200تلميذ اريد ان اجعل في صفحةاكسل اخرى (غير التي فيها الجدول) مختصر له بحيث اذا كتبت اسم و لقب التلميذ يظهر قسمه و تاريخ ميلاده و صفته

حمّل جزء بسيط من  الملف ( 10 الى 15 اسم فقط ) و ليس 1200 اسم  لاجراء اللازم

[مصطفى محمود مصطفى]

السلام عليكم

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

التعديل اكثر من رائع وهو المطلوب بالفعل

حفظكم الله واعطاكم الصحة والعافية

لكم وافر احترامي وتقديري

[مصطفى محمود مصطفى]

السلام عليكم

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

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

لان عندما يعمل يمسح المكرر تمام لكم يقوم بمسح التنسيقات مثل التاريخ او غيره

هل يمكن ان يكون المسح للبيانات ويستثني التنسيق

تحياتي لكم

Sub Remove_Dup()
Sheets("Summary").Range("b5").CurrentRegion.RemoveDuplicates _
 Columns:=Array(2, 3, 4, 5, 6, 7), Header:=1
End Sub

استاذ سليم وفقكم الله هذا الكود لحضرتكم يقوم بحذف الصفوف المكررة

ويبقي تنسيق التاريخ

هل يمكن تجربته على ملفي

لاني اضفته ولم يعمل 

تحياتي لكم

Sub Del_row()
Dim i As Long
Dim lr As Long: lr = Cells(Rows.Count, 1).End(3).Row
Range("CV3:CV" & lr).Formula = "=SUMPRODUCT(--(c3&d3&e3&f3&g3&h3=$c$3:c3&$d$3:d3&$e$3:e3&$f$3:f3&$g$3:g3&$h$3:h3))"
Range("CV3:CV" & lr).Value = Range("CV3:CV" & lr).Value
For i = lr To 3 Step -1
 If Cells(i, "CV") > 1 Then Cells(i, "CV").EntireRow.Delete
 Next
 Range("CV:CV").ClearContents
End Sub

 

تم تعديل سبتمبر 22, 2018 بواسطه مصطفى محمود مصطفى

[سليم حاصبيا]

الماكرو المطلوب 

مبدئياً انقل الداتا الى صفجة مستقلة (انشاء صفحة جديدية)

 نفذ عليها ها الماكرو (يجب ان تيدأ البيانات من الخلية B4

قي المعادلة التي كتبتها انا  يوجد * يجب وضعها حتى تعمل الدالة بشكل جيد

لان الدالة (عند اسنعمال &) نتظر الى الرفمين  211  و 55   ( 55211) و تنطر الى الرقمين 

11  و  552   (55211) اي نفس الشيء 

بنما عند استعمال النجمة يصبحون هكذا (211*55) و (11*552) مختلفين

Option Explicit
Sub Del_row()
Dim i As Long
Dim lr As Long: lr = Cells(Rows.Count, 2).End(3).Row
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
Range("k4") = "salim"

Range("k5:k" & lr).Formula = "=SUMPRODUCT(--(c5&d5&e5&f5&g5&h5=$c$5:c5&$d$5:d5&$e$5:e5&$f$5:f5&$g$5:g5&$h$5:h5))"
Range("k5:k" & lr).Value = Range("k5:k" & lr).Value
Range("M2").Formula = "=K5<>1"

 Range("k5:k" & lr).AdvancedFilter xlFilterInPlace, criteriarange:=Range("M1:M2")
 Range("k5:k" & lr).SpecialCells(12).EntireRow.Delete
 
 On Error Resume Next
 ActiveSheet.ShowAllData
 On Error GoTo 0
 Range("k4:k" & lr).Clear: Range("m2").Clear
 
End Sub

 

[مصطفى محمود مصطفى]

السلام عليكم

الاستاذ سليم وفقكم الله وحفظكم من كل سوء

نسال الله ان يعطيكم العافية لاخلاصك وتفانيك في مساعدة الناس

اثابكم الله في عملكم وجعل جميع اعمالكم في ميزان حسناتكم

لكم وافر احترامي وتقديري

 

[مصطفى محمود مصطفى]

23 ساعات مضت, سليم حاصبيا said:

 نفذ عليها ها الماكرو (يجب ان تيدأ البيانات من الخلية B4

استاذ سليم جزاكم الله خيرا واعطاكم الصحة والعافية

هل بالامكان تغيير بداية الكود من الخلية  c4

لكم وافر الاحترام والتقدير