اذهب الي المحتوي
أوفيسنا

طلب اضافة ترحيل بيانات بملف اكسل

almahari

بواسطه almahari
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

almahari

almahari

قام بنشر
قام بنشر

السلام عليكم

الملف خاص بالعمل لكثرة البيانات قمت بتصميم ملف اكسل ، المرفق هنا ، وعملت مكان للبحث وهو ممتاز لإظهار النتائج من الجدول 

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

t-2019.rar

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

لا حاجة للمعادلات في هذا املف 

الـــ Vba يقوم بكل ما يناسب

الملف مرفق مع الشرح

الكودات اللازمة 

Option Explicit
Sub Edit_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#
Union(Range("b8:l8"), Range("c9:l9")).ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("d6"))
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
 End If
r = Source_rg.Find(Me.Range("d6")).Row

 With Me.Range("b8")
  .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4)
  .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7)
  .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10)
  .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12)
  .Offset(1, 1) = Cells(r, 13)
  End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ADD_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#

Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("d2"))
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
    
 End If
 r = Find_rg.Row
 With Me.Range("b4")
   Cells(r, 2) = .Value: Cells(r, 3) = .Offset(, 1): Cells(r, 4) = .Offset(, 2)
   Cells(r, 5) = .Offset(, 3): Cells(r, 6) = .Offset(, 4): Cells(r, 7) = .Offset(, 5)
   Cells(r, 8) = .Offset(, 6): Cells(r, 9) = .Offset(, 7): Cells(r, 10) = .Offset(, 8)
   Cells(r, 11) = .Offset(, 9): Cells(r, 12) = .Offset(, 10): Cells(r, 13) = .Offset(1, 1)
 End With
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub Ta3dil()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#
Union(Range("B4:L4"), Range("C5:L5")).ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("D2"))
 If Find_rg Is Nothing Then
    MsgBox "This Number Does't Exists"
    Exit Sub
 End If
r = Source_rg.Find(Me.Range("D2")).Row

 With Me.Range("b4")
  .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4)
  .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7)
  .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10)
  .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12)
  .Offset(1, 1) = Cells(r, 13)
  End With
End Sub

 

T-2019_Salim.xlsm

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك
almahari

almahari

قام بنشر
  • الكاتب
قام بنشر

بارك الله فيكم رائع العلم والاروع  الا يبخل الانسان بعلمه جزاك عنا الله خيرا 

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

 

99.jpg

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

هذه الصورة من اعدادات الاكسل في جهازك (تقول ان هذا الملف فيه معلومات شخصية ويسألك الحفظ ) اضغط موافق

في هذا العنوان شرح لهذه الرسالة وكيفية ازالتها اذا اردت

https://feasibility.pro/careful-excel-warning/

اذا كان الجواب يفضي بالغرض المطلوب  اضغط على افضل اجابة لغلقه

  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

ربما هذا الكود اسرع قليلاُ وأقصر في نفس الوقت (يمكنك استعماله)

  

Option Explicit
Sub Edit_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#
Union(Range("b8:l8"), Range("c9:l9")).ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("d6"))
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
 End If
r = Source_rg.Find(Me.Range("d6")).Row

 With Me.Range("b8")
    .Resize(, 11).Value = Cells(r, 2).Resize(, 11).Value
    .Offset(1, 1) = Cells(r, 13)
 End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ADD_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#

Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("d2"))
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
    
 End If
 r = Find_rg.Row
 With Me.Range("b4")
  Cells(r, 2).Resize(, 11).Value = .Resize(, 11).Value
  Cells(r, 13) = .Offset(1, 1)
 End With
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub Ta3dil()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#
Union(Range("B4:L4"), Range("C5:L5")).ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("D2"))
 If Find_rg Is Nothing Then
    MsgBox "This Number Does't Exists"
    Exit Sub
 End If
r = Source_rg.Find(Me.Range("D2")).Row

 With Me.Range("b4")
    .Resize(, 11).Value = Cells(r, 2).Resize(, 11).Value
    .Offset(1, 1) = Cells(r, 13)

  End With
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
  • 5 months later...
almahari

almahari

قام بنشر
  • الكاتب
قام بنشر

بارك الله عملكم يا أخوتي ، وجعل الله عامكم عام بالخير  أستادنا سليم 
أستاذنا عندما ، حاولت أ أغير في رقم الاقرار الجانبي لكي يبداء من العدد   1  بدل من 6000 لم يستجب المكرو لذلك ولغبط الادخال ، هل يمكن المساعده بارك الله فيكم ، نفس الملف المرفق 

رابط هذا التعليق
شارك
almahari

almahari

قام بنشر
  • الكاتب
قام بنشر

الاستاذ سليم حاصبيا ، بارك الله فيكم 

https://www.officena.net/ib/topic/92360-طلب-اضافة-ترحيل-بيانات-بملف-اكسل/?tab=comments#comment-578135  هنا الموضوع الاصلي 

وطلبي هو ان يبداء رقم الاقرار من رقم 1 وليس 6000 حاولت التغيير ولكن الملف يخلط ولا يستجيب 

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

الحل

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

Option Explicit
Sub Edit_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#
Union(Range("b8:l8"), Range("c9:l9")).ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("D6"), Lookat:=1)
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
 End If
r = Source_rg.Find(Me.Range("d6")).Row

 With Me.Range("b8")
  .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4)
  .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7)
  .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10)
  .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12)
  .Offset(1, 1) = Cells(r, 13)
  End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub ADD_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#

Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("d2"), Lookat:=1)
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
    
 End If
 r = Find_rg.Row
 '========================================
 With Me.Range("b4")
   Cells(r, 2) = .Value: Cells(r, 3) = .Offset(, 1): Cells(r, 4) = .Offset(, 2)
   Cells(r, 5) = .Offset(, 3): Cells(r, 6) = .Offset(, 4): Cells(r, 7) = .Offset(, 5)
   Cells(r, 8) = .Offset(, 6): Cells(r, 9) = .Offset(, 7): Cells(r, 10) = .Offset(, 8)
   Cells(r, 11) = .Offset(, 9): Cells(r, 12) = .Offset(, 10): Cells(r, 13) = .Offset(1, 1)
 End With

End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++
Sub Ta3dil()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#
Union(Range("B4:L4"), Range("C5:L5")).ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Find(Me.Range("D2"), Lookat:=1)
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
 End If
r = Source_rg.Find(Me.Range("D2")).Row

 With Me.Range("b4")
  .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4)
  .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7)
  .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10)
  .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12)
  .Offset(1, 1) = Cells(r, 13)
  End With
End Sub

 

 اضافة عبارة  LookAt:=1  الى كل العبارات التي تحتوي على Set Find_rg

 

الملف من جديد

 

T-2019_Salim_new.xlsm

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
almahari

almahari

قام بنشر
  • الكاتب
قام بنشر

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

ارفقت لكم الملف ، نفسة مع تعديل رقم الاقرارات ، مثلا تظعر رقم 5 لجلب بيانات الاقرار ، الذي يظهر بيانات الاقرار 6 و هاكذا عندما حاولت ان ادرج 50 ملف طلعت النتيجة ملفات مكرره لم انتبه الا بعد المراجعه 

هل هناك اشكالية لم افهمها او هناك كود يتعطل فجئة 

كلي امل وخجل منكم استاذنا بارك الله علمكم 

T-2019_Salim_new.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

تم معالجة الامر 

Option Explicit
Sub Edit_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#

Range("B8:M8").ClearContents
Range("B4:M4").ClearContents
Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Columns(2).Find(Me.Range("D6"), Lookat:=1)
 If Find_rg Is Nothing Then
    MsgBox "'This Number Does't Exists"
    Exit Sub
 End If

r = Find_rg.Row
 With Me.Range("B8")
  .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4)
  .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7)
  .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10)
  .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12)
  .Offset(, 11) = Cells(r, 13)
  End With
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub ADD_data()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#

Dim lra#: lra = Me.Cells(Rows.Count, 2).End(3).Row + 1

Set Source_rg = Me.Range("a12:M" & lra)
If Me.Range("d2") = "" Then MsgBox "NO data to Enter": Exit Sub
Set Find_rg = Source_rg.Find(Me.Range("d2"), Lookat:=1)
 If Not Find_rg Is Nothing Then MsgBox "This activity is exits": Exit Sub
Range("B4:M4").Copy
Cells(lra, 2).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False: Me.Range("d2").Select
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++
Sub Ta3dil()
Dim Source_rg As Range
Dim Find_rg As Range
Dim r#

Dim lra#: lra = Me.Cells(Rows.Count, 2).End(3).Row
Set Source_rg = Me.Range("a12:M" & lra)
Set Find_rg = Source_rg.Columns(2).Find(Me.Range("D2"), Lookat:=1)
 If Not Find_rg Is Nothing Then MsgBox "This activity is exits": Exit Sub
Range("B4:M4").Copy
Cells(lra + 1, 2).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False: Me.Range("d2").Select

End Sub

 

T-2019_Salim_UPDATE.xlsm

  • Like 1
  • Sad 1
رابط هذا التعليق
شارك
almahari

almahari

قام بنشر
  • الكاتب
قام بنشر

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

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

والادخال والاستدعاء يكون عن طريق رقم الاقرار 

وهي ارقام وليست حروف مثل ما وجدت بالملف المرفق لكم mmr  و A  وهنا اضن حدث الاشكال في الاستجابه 

ارهقني هذا الملف استاذنا ولم اجد له حل 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept