ترحيل البيانات

[حمود الحارثي]

الاساتذه الكرام

كل عام وانتم بخير

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

 

اتمني بان اكون قد وفقة بشرح المطلوب ولكم مني جزيل الشكر والتقدير

Salary Assignment .rar

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

تم معالجة الامر وتعديل المعادلات للحصول على سرعة أفضل

اذ ليس من المعقول ان تأخذ جدولا من b4  الى xfd4   ونزولاً  على كل الصفوف  اي  أكثر 17 مليار خلية  (عدد سكان الارض  ضرب 3)

لتبحث من خلاله على خلية واحدة

الكود

Sub trasnfer_data()
Dim DE As Worksheet, D As Worksheet
Dim My_ro%
Set DE = Sheets("Data Enter"): Set D = Sheets("Data")
My_ro = D.Cells(Rows.Count, 3).End(3).Row
With D
 .Cells(2, 1).Resize(My_ro, 64).Interior.ColorIndex = xlNone
 .Range("C" & My_ro + 1) = DE.[k8]
 .Range("N" & My_ro + 1) = DE.[k10]
 .Range("BV" & My_ro + 1) = DE.[k12]
 .Range("BM" & My_ro + 1) = DE.[k14]
 'ok
 '=============================
 .Range("F" & My_ro + 1) = DE.[I16]
 .Range("Br" & My_ro + 1) = DE.[O16]
 .Range("E" & My_ro + 1) = DE.[AD6]
 
 '===========================
 .Range("R" & My_ro + 1) = DE.[Af8]
 .Range("D" & My_ro + 1) = DE.[AD10]
 .Range("Q" & My_ro + 1) = DE.[ad12]
 .Range("G" & My_ro + 1) = DE.[ad14]
 .Range("J" & My_ro + 1) = DE.[ad16]
 .Cells(My_ro + 1, 1).Resize(, 64).Interior.ColorIndex = 6
End With

End Sub

الملف

 

My_Salary .xlsm

[حمود الحارثي]

الاستاذ سليم

لك مني جزيل الشكر والتقدير

شاكر الجهد لميذول ولكن ليس هوه المطلب

المطلوب عالى النحو التالي

 

    -1 في الخليه  ِAD6    ( يوجد للموظف اكثر من طلب المطلوب إيجاد اخر تاريخ لطلب الموظف من الشيت -  Data )

 

2 و3 - في الخليه O16  و ِAD16 ( توجد دالة VLOOKUP  لجلب البيانات المدخله سابقا للموظف في الشيت Data  -  اذا لم توجد اي بيانات سوف نقوم بادخالها يدويا بعد الظغط على ( New Request  ) تترحل البيانات الجديده في الشيت data  وتضل الفورمله  موجوده في الخليه لا تختفي ولا تتاثر .

 

-  في شيت Print  تظهر فيه طلبات الموظفين لنفس اليوم فقط اذا فتح الملف في اليوم الثاني بيكون خالي عندما يتم اظافة طلب جديد يترحل اسم الموظف في الشيت برينت لطباعة الرساله ( للعلم سوف يتم ربط الملف بالاورد لطباعة الرساله )

 

اتمنى بان اكون قد وفقة بتوضيح المطلوب ولكم مني جزيل الشكر والتقدير

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

 في الخليه  ِAD6    ( يوجد للموظف اكثر من طلب المطلوب إيجاد اخر تاريخ لطلب الموظف من الشيت -  Data )

هذا ما تفعله النعادلة الموضوعة في AD6 )جرب ان تغير التاريخ  في الشيت data  وترى النتيجة)

[حمود الحارثي]

تسلم استاذي الكريم 

وانتظر المساعده في الامواضيع الاخرى

 

2 و3 - في الخليه O16  و ِAD16 ( توجد دالةVLOOKUP  لجلب البيانات المدخله سابقا للموظف في الشيت Data  -  اذا لم توجد اي بيانات سوف نقوم بادخالها يدويا بعد الظغط على (New Request  ) تترحل البيانات الجديده في الشيت data  وتضل الفورمله  موجوده في الخليه لا تختفي ولا تتاثر

[حمود الحارثي]

الاساتذه الكرام 

اتمنى مساعدتكم في الملف المرفق عمل زر استدعاء وترحيل البيانات او المساعده في كود الترحيل في حالة التعديل في البيانات بعد ترحيل البيانات تضل الداله موجوده .

اتمنى المطلوب واضح 

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

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

 

[حمود الحارثي]

اشكرك استاذي الجليل

وما الحل اريد اعمل استدعاء البيانات وفي حالي التعديل عليها استطيع التعديل وترحيلها في شيت لتخزين في شيت اخر كون الملف مربوط بملف اخر الاورد.  

 

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

تستطيع انشاء جدولين واحد تدخل فيه المعادلات والثاني تسنعمل فيه الكود

[حمود الحارثي]

لك جزيل الشكر استاذي 

كيف لي القيام بهذا وهل من الممكن  عمل زر التعديل على البيانات قبل ترحيلها الي الجدول الثاني 

[حمود الحارثي]

 اتقدم بخالص الشكر والتقدير للقايمين في هذا الصرح التعليمي.

وكل عام وانتم بخير 

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

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

صديقي الملف الذي تعمل عليه يظهر بهذا الشكل (بعد ازالة نتسيقاته للنظر فيه عن قرب)

كل الذي تحتاجه 5 او 6 اعمدة للعمل عليها (ليس من العامود الاول الى العامود AA)

ما الفائدة مثلاً من دمج الخلايا من K حتى Ab لكتابة كلمة SHANKILAND

(يكفي وضع هذه الكلمة في الخلية  K  مع توسيع العامود حسب ما تريد)

كيف تريد العمل على هكذا ملف الذي يحتوي على مئات الخلايا المدمجة التي تعيق عمل اي دالة او كود 

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

هكذا يجب ان يكون جدولك (الصفحة  SALIM من هذا الملف) ليقوم اي كود او معادلة بعمله على اكمل وجه

كما تلاحظ ان حجم الملف انخفض من 1.17 ميغا الى 40 كيلو فقط اي حوالي 30 مرة

الملف مرفق للتعديل عليه لاجراء ما يلزم

 

My_Salary_New .xlsm

[حمود الحارثي]

استاذي الجليل

لك ارقى تحيه وتجليل على ما تبذله من جهد جعله الله في ميزان حسناتك وفق الله وحفظك من كل سؤ

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

اتا اريد ان تضل الفرمله  موجوده بعد الترحيل او نستخدم ماكرو بدل الفرمله واظافة زر تحديث في حالة تحديث اي بيانات . 

 

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

 سبق و قلت لك

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

لذا عليك ادراج جدول اخر مماثل  (بدون معادلات ) اسفل الجدول الحالي     تقوم بتعبئته بما تريد ، الجدول المستحدث يكون مصدراً للبيانات التي تنوي ترحيلها الى اي شيت تريدها

[حمود الحارثي]

لك اجمل تحيه استاذي الجليل 

سوف احاول باذن الله 

 

كل عام وانت بخير

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

تم معالجة الامر كما تريد

هناك زران واحد لجلب البيانات من الشيت Master واخر لارسالها الى الشيت Data (يمكنك اضافة اعمدة في الشيت  Data  قدر ما تريد ابتداء من العامود M

الماكرو الاول لجلب البيانات من الشيت Master والثاني  لارسالها الى الشيت Data

Option Explicit
Sub give_data()
Rem ====>> Created By Salim hasbaya 9/8/2019
Dim x As Boolean
x = IsError(Application.Match([b3], Sheets("MASTER").Range("B4:B10000"), 0))
If x Then
MsgBox "This Recorde: " & [b3] & " Not Exists" & Chr(10) & _
     "Please  Check the value of the cell B3", , "Salim Tell Yuo"
Range("Info_range") = vbNullString
Exit Sub
End If
Dim FB4$: FB4 = _
    "=INDEX(MASTER!$C$4:$C$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FB5$: FB5 = _
    "=INDEX(MASTER!$N$4:$N$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FB6$: FB6 = _
    "=INDEX(MASTER!$BV$4:$BV$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FB7$: FB7 = _
    "=INDEX(MASTER!$BM$4:$BM$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FB8$: FB8 = _
     "=INDEX(MASTER!$F$4:$F$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
    '=============================
Dim FD4$: FD4 = _
    "=INDEX(MASTER!$E$4:$E$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FD5$: FD5 = _
    "=INDEX(MASTER!$D$4:$D$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FD6$: FD6 = _
    "=INDEX(MASTER!$Q$4:$Q$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
Dim FD7$: FD7 = _
     "=INDEX(MASTER!$G$4:$G$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
    
Dim FD8$: FD8 = _
     "=INDEX(MASTER!$BR$4:$BR$10000,MATCH(B3,MASTER!$B$4:$B$10000,0))"
    '========================
 
 Range("b4") = Evaluate(FB4): Range("b5") = Evaluate(FB5)
 Range("b6") = Evaluate(FB6): Range("b7") = Evaluate(FB7)
 Range("b8") = Evaluate(FB8)
 Range("D3").FormulaArray = _
 "=INDEX(Data!$E$3:$E$1000,MAX(IF(Data!$C$3:$C$10000=b3,ROW($A$3:$A$11)-2,"""")))"
 Range("D3").Value = Range("D3").Value: Range("D4") = Evaluate(FD4)
 Range("D5") = Evaluate(FD5): Range("D6") = Evaluate(FD6)
 Range("D7") = Evaluate(FD7): Range("D8") = Evaluate(FD8)
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++
Sub trasnfer_data()
Rem ====>> Created By Salim hasbaya 9/8/2019 Macro N#2
Dim DE As Worksheet, D As Worksheet
Dim My_ro%, cont%, Anser As Byte
Set DE = Sheets("SALIM"): Set D = Sheets("Data")
cont = Application.CountIf(D.Range("a:a"), DE.Range("b3"))
If cont <> 0 Then
 Anser = MsgBox("this recorde is alreday exist" & Chr(10) & _
   "do you want to add it??", vbYesNo)
   If Anser <> 6 Then Exit Sub
End If
My_ro = D.Cells(Rows.count, 1).End(3).Row
With D
 .Cells(2, 1).Resize(My_ro, 64).Interior.ColorIndex = xlNone
   With .Range("A" & My_ro + 1)
  .Value = DE.[b3]
  .Offset(, 1) = DE.[B4]: .Offset(, 2) = DE.[B5]
  .Offset(, 3) = DE.[B6]: .Offset(, 4) = DE.[B7]
   '=============================
  .Offset(, 5) = DE.[B8]: .Offset(, 6) = DE.[D3]
  .Offset(, 7) = DE.[D4]: .Offset(, 8) = DE.[D5]
  .Offset(, 9) = DE.[D6]: .Offset(, 10) = DE.[D7]
  .Offset(, 11) = DE.[D8]
  '===========================
.Resize(, 12).Interior.ColorIndex = 6
 End With
End With
' My_data = DE.[k6]
End Sub

الملف مرفق من جديد

My_Salary_Updated .xlsm

[حمود الحارثي]

الاستاذ سليم

جزاك الله عنا خير جزاء ولك مني ارقى تحيه

وزادك الله من فضله

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

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

مباشرة قبل كلمة End sub في الماكرو الثاني (trasnfer_data) اضف هذا السطر

Union(DE.Range("B3:B8"), DE.Range("D3:D8")).ClearContents

 

[حمود الحارثي]

استاذي الجليل

1. هل من الممكن جعل البيانات المرحله الى الشبت ( Data ) تبدء من العمود D  بدل من العمود A.

2. عندما يتم ادخال رقم وظيفي غير موجود في ( Master ) لا يتم تريحيل.

3. وهل من الممكن اذا تم تغيير ( Department) او ( Position) بعد استدعاء البيانات في الشيت ( Home) عند الضغط على زر الترحيل تترحل البيانات وفي نفس الوقت تتحدث البيانات في شيت ( Master) للموظف المرحله بياناته

حاولت ان اعمل هذه الخطوات ولكن بسبب قلة الخبره لم استطيع ولك مني جزيل الشكر والتقدير وزادكم الله من علمه .

[حمود الحارثي]

صباح الخير 

الاساتذه الكرام هل يوجد حل لطبي هذا 

[رشاد احمد]

تحيه منى للاستاذ سليم لانه لا يبخل بشئ من علمه وتحيه لجميع الاعضاء والاداريين

[مهند محسن]

اخى حمود الحارثي الموضوع ليس بالسهل او الهين

فالطلبات كثيرة جدا والموضوع كبير

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

فأعتقد ان هذا يكفى لهذا الموضوع واترك بعض الوقت الأساتذة لكى تتمكن من مساعدة غيرك من الأعضاء الذين لديهم أيضا مشاكل يريدون مساعدة الأساتذة فيها

بارك الله فيك

[حمود الحارثي]

استاذ مهند لك ارقى تحيه وانا مقدر الجهود المبذوله والملموسه من الاساتذه الكرام لمساعدة الاعضاء المشاركين.

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

كما تلاحظ بان الملف غير كامل ولا استطيع العمل عليه ومن الصعب اتركة بهذا الشكل احتراما" وتقديرا الاستاذ سليم.

كنت اتمنى ان يجهز هذا الملف لاستفيد منه في عملي وليستفيد منه الاخرين.

ارقى تحيه للقائمين في هذا الصرح التعليمي وللاساتذه الكرام جزاهم الله الف خير .