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

almahari · يوليو 9, 2019

السلام عليكم

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

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

t-2019.rar

**سليم حاصبيا** · يوليو 9, 2019

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

الـــ 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

almahari · يوليو 9, 2019

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

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

**سليم حاصبيا** · يوليو 9, 2019

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

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

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

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

almahari · يوليو 9, 2019

زادكم الله في العلم شكرا استاذنا الكريم

**سليم حاصبيا** · يوليو 9, 2019

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

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

almahari · ديسمبر 30, 2019

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

almahari · ديسمبر 31, 2019

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

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

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

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

**سليم حاصبيا** · ديسمبر 31, 2019

الحل

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

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

almahari · يناير 1, 2020

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

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

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

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

T-2019_Salim_new.xlsm

**سليم حاصبيا** · يناير 6, 2020

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

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

almahari · يناير 6, 2020

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

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

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

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

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

تسجيل الدخول

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

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

almahari

سليم حاصبيا

almahari

سليم حاصبيا

almahari

سليم حاصبيا

almahari

almahari

سليم حاصبيا

almahari

سليم حاصبيا

almahari

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information