ادخال بيانات لأكثر من جدول بالتتابع في نفس الشيت

[osama elmorsy]

السلام عليكم يا حضرات الاساتذة الأفاضل

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

مرفق الملف الذي أعمل علية

وشكرا مقدما لحضراتكم 

نموذج.xlsm

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

جرب هذا الكود

Private Sub CommandButton1_Click()
Dim D As Worksheet
Dim P As Worksheet
Dim How_many%, I%, x%
Dim Arr_sh(), arr_From()
Arr_sh() = Array("PAGE1", "PAGE2", "PAGE3")
arr_From = Array("E3", "D5", "D7", "D9", "D11", _
           "G5", "G7", "G9")
           Set D = Sheets("Data")
           
    For I = LBound(arr_From) To UBound(arr_From)
      If D.Range(arr_From(I)) = vbNullString Then
         MsgBox "Imcopmlete Data In: " & Chr(10) & _
         D.Range(arr_From(I)).Address & Chr(10) & _
         "I Cannot contenue", 64
        Exit Sub
      End If
    Next
           
  For I = 0 To 2
      If Application.CountA(Sheets(Arr_sh(I)).Range("b8:b37")) < 30 Then
         Set P = Sheets(Arr_sh(I))
         Exit For
     End If
 Next
    If P Is Nothing Then Exit Sub
     
  How_many = Application.CountA(P.Range("b8:b37")) + 8
  
  With P.Cells(How_many, "B")
    For I = LBound(arr_From) To UBound(arr_From)
     .Offset(, I) = D.Range(arr_From(I))
    Next
  End With
   
   x = Application.CountA(P.Range("b8:b37"))
  P.Range("A8").Resize(x).Value = _
  Evaluate("Row(1:" & x & ")")
  
  For I = LBound(arr_From) To UBound(arr_From)
   D.Range(arr_From(I)) = vbNullString
  Next
  
  
End Sub

osama elmorsy.xlsm

[osama elmorsy]

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

وان شاء الله الواحد لو احتاج يستفسر عن شيئ هيكون واثق ان في ناس زي حضرتك هترد علية شكرا لحضرتك استاذي

[osama elmorsy]

كنت طلبت في موضوع سابق كود ترحيل بيانات من لشيت اخر وعند انتهائة ينتقل للشيت الذي يلية ورد علي الأستاذ الفاضل "سليم حاصبيا" وحل لي المشكلة

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

وهذا كود الأستاذ سليم 

ومرفق ملف العمل موضح فية ماذا اعني ولحضراتكم جزيل الشكر والثناء

تجربة (2).xlsm

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

وضعت لك كود للزر الأول 

يمكنك اقتباسه لياقي الازرار

Option Explicit
Sub Masrouf() 'CommandButton4
Dim D As Worksheet
Dim P As Worksheet
Dim How_many%, I%, x%
Dim Arr_sh(), arr_From()
Arr_sh() = Array("يومية1", "يومية2", "يومية3")
arr_From = Array("M6", "P6")
           Set D = Sheets("إدخال البيانات")
         
'    For I = LBound(arr_From) To UBound(arr_From)
'     D.Range(arr_From(I)) = Chr(Application.RandBetween(65, 90))
'    Next
    
    For I = LBound(arr_From) To UBound(arr_From)
      If D.Range(arr_From(I)) = vbNullString Then
         MsgBox "بيانات غير مكتملة: ", 64
        Exit Sub
      End If
    Next
   For I = 0 To 2
 If Application.CountA(Sheets(Arr_sh(I)).Range("K8:K17")) < 10 Then
 Set P = Sheets(Arr_sh(I))
 Exit For
 End If
 Next
    If P Is Nothing Then Exit Sub
   How_many = Application.CountA(P.Range("K8:K17")) + 8

  With P.Cells(How_many, "K")
    For I = LBound(arr_From) To UBound(arr_From)
     .Offset(, I) = D.Range(arr_From(I))
    Next
  End With

   x = Application.CountA(P.Range("K8:K17"))
  P.Range("J8").Resize(x).Value = _
  Evaluate("Row(1:" & x & ")")

  For I = LBound(arr_From) To UBound(arr_From)
   D.Range(arr_From(I)) = vbNullString
  Next
   
    
End Sub
        

Osama_More_but.xlsm

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

الكود لا بلعي سيئاً

[osama elmorsy]

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

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

الماكرو الجدبد ينفذه الزر الثاني (اللون الأحمر) (CommandButton4) و ليس الزر الاول

[osama elmorsy]

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

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

تضع الكود في موديل غير موديل الضفحة (Salim_Mod مثلاً او تنشأ موديل جديد كما تريد) (تفوم بالتعديل كما تريد ضروري اعطاءه اسم جدبد غيرMasrouf ) و يتم استدعاء الكود الجديد من موديل الصفحة (بالضبط كما الكود  الأول)

 

[osama elmorsy]

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

وهذا كود الاستاذ سليم

ولكم وافر الشكر والامتنان لحضراتكم

نموذج ادخال.xlsm

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

تغيير اسماء الشيتات الى  Data   و   Youmiya

Private Sub CommandButton1_Click()
Dim D As Worksheet
Dim Y As Worksheet
Dim F_rg  As Range
Dim How_many%, I%, x%, Ro%
Dim Arr_sh(), arr_From()

Arr_sh() = Array("B8", "B47", "B86")
arr_From = Array("E10", "E12", "E14", "H10", "H12", _
           "H14", "F16")
           Set D = Sheets("Data")
           Set Y = Sheets("Youmia")
'      For I = LBound(arr_From) To UBound(arr_From)
'       D.Range(arr_From(I)) = Chr(Application.RandBetween(65, 90))
'      Next
           
    For I = LBound(arr_From) To UBound(arr_From)
      If D.Range(arr_From(I)) = vbNullString Then
         MsgBox "بيانات الحالة غير مكتملة" & Chr(10) & _
         "أكمل البيانات", 524352
        Exit Sub
      End If
    Next
  For I = 0 To 2
 
  If Application.CountA(Y.Range(Arr_sh(I)).Resize(30)) < 30 Then
   How_many = Application.CountA(Y.Range(Arr_sh(I)).Resize(30))
  End If
 Exit For

 Next
  With Y.Cells(How_many + 8, "B")
    For I = LBound(arr_From) To UBound(arr_From)
     .Offset(, I) = D.Range(arr_From(I))
    Next
  End With
  For I = LBound(arr_From) To UBound(arr_From)
   D.Range(arr_From(I)) = vbNullString
  Next
  MsgBox "تمت إضافة البيانات", vbInformation, "Done"

End Sub

 

Osama One_sheet.xlsm

[osama elmorsy]

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

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

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

تم التعديل على الماكرو

Private Sub CommandButton1_Click()
Dim D As Worksheet
Dim Y As Worksheet
Dim F_rg  As Range
Dim How_many%, I%, x%, Ro%
Dim Arr_sh(), arr_From()
Dim Bool As Boolean

Arr_sh() = Array("B8", "B47", "B86")
arr_From = Array("E10", "E12", "E14", "H10", "H12", _
           "H14", "F16")
           Set D = Sheets("Data")
           Set Y = Sheets("Youmia")
'      For I = LBound(arr_From) To UBound(arr_From)
'       D.Range(arr_From(I)) = Chr(Application.RandBetween(65, 90))
'      Next
           
    For I = LBound(arr_From) To UBound(arr_From)
      If D.Range(arr_From(I)) = vbNullString Then
         MsgBox "بيانات الحالة غير مكتملة" & Chr(10) & _
         "أكمل البيانات", 524352
        Exit Sub
      End If
    Next
  
  For I = 0 To 2
   How_many = Application.CountA(Y.Range(Arr_sh(I)).Resize(30))
      Bool = IIf(How_many = 30, True, False)
      If Not Bool Then Exit For
  Next
  
   With Y.Range(Arr_sh(I)).Cells(1).Offset(How_many)
    For I = LBound(arr_From) To UBound(arr_From)
     .Offset(, I) = D.Range(arr_From(I))
    Next
  End With
  
  For I = LBound(arr_From) To UBound(arr_From)
   D.Range(arr_From(I)) = vbNullString
  Next
  MsgBox "تمت إضافة البيانات", vbInformation, "Done"

End Sub

 

[osama elmorsy]

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