مساعدة في ترحيل البيانات من صفحة الى صفحة

[laminedch]

السلام عليكم 

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

هدا نمودج بارك الله فيكم

1616.xlsx

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

في هذا الملف

1- الصفحة Result حيث تظهر النتيجة 3 صفوف تحنوي بيانات مهمه ليغمل عليها الكود
       الصفوف (5/4/3   مخفية) عدم المس بها كي لا يتعطل عمل الماكرو
       الصف رقم 5 يجب ان يكون فارغاُ نهائياً لقصل رأس الجدول عن البيانات
2-تكرار البيانات غير مسموح (الماكرو يحذف المكرر اذا كانت جميع بيانات الصف الواجد مكررة)
       بمعنى اخر اذا كبست الزر اكثر من مرة  دون تعديل البيانات لا يعمل الماكرو أكثر من مرة واحدة الماكرو

 3 -الزر  Clear يمسح البيانات من source التي لا تحتوي على معادلات
   

 

 

Option Explicit

Sub Get_data()
    Dim S As Worksheet
    Dim R As Worksheet
    Dim i%, m%, Mx%
    Dim ArS(1 To 20)
    Dim ArR(1 To 20)

Set S = Sheets("Source")
Set R = Sheets("Result")

m = R.Cells(Rows.Count, 2).End(3).Row + 1
If m < 6 Then m = 6

For i = 2 To 21
 ArS(i - 1) = R.Cells(3, i)
 ArR(i - 1) = R.Cells(4, i)
Next

For i = 1 To 20
  R.Cells(m, ArR(i)).Value = _
  S.Range(ArS(i)).Value
Next
 
 R.Cells(6, 2).Resize(m - 5, 20). _
 RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _
   8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20), Header:=xlNo
   Mx = R.Range("B6").CurrentRegion.Rows.Count
 
  If R.Cells(6, 2) <> vbNullString Then
   With R.Cells(6, 1).Resize(Mx)
    .Value = Evaluate("Row(1:" & Mx & ")")
        With .Resize(, 21)
         .Borders.LineStyle = 1
         .Font.Bold = True
        End With
   End With
  End If

End Sub

الملف مرفق

laminedch.xlsm

[أحمد يوسف]

  laminedch

أين انت من  هذه الإجابة الممتازة؟!!! لم أرى اى ضغط على الإعجاب من طرفك , وهل جزاء الإحسان الا الإحسان ؟!!!!

أين الضغط على الإعــــجـــــاب , وكما اتفقنا ان هذا أقل ما يقدم لمن له الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!! 💙