تعديل كود ترحيل من نموذج إدخال الى صفحة أخرى

[roukaf12]

إلى زملائي الأعزاء السلام عليكم ورحمة الله وبركات 

في الملف المرفق حاولت ترحيل البيانات إلى شيت آخر ولكني كل مره أفشل بيها  من فضلكم افادتي بكود ترحيل عملي أو ارسال الكود في الرد وفي حال توفر وقت لديكم برجاء الشرح 

Sub Tarheel()
Dim d(5), x(5, 30)
d(1) = [G7]: d(2) = [C4]: d(3) = [C8]: d(4) = [H8]: d(5) = [C9]
With Sheets("Data")
DR = .[H10000].End(xlUp).Row + 1         '
    For i = 1 To 5
        .Cells(DR, i + 1) = d(i)
    Next i
End With
LR = [H30].End(xlUp).Row
Range("C12:G" & LR).Copy
Sheets("Data").Select
    Range("G" & DR).Select
    Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
[F2].Select
Sheets("Permession").Select
Reply = MsgBox("All data will be transfer " & Chr(10) & "it's done", vbYesNo)
If Reply <> 6 Then Exit Sub
Range("B12:C29, B29").ClearContents
[G7] = [G7] + 1
Range("D8:D10, F9").ClearContents
End Sub

عنوان مخالف جداً ... تم تعديل وتغيير عنوان المشاركة ليعبر عن طلبك

تصريح.xlsm

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

جرب هذا الماكرو

Option Explicit
Sub Tarheel()
    Dim Mon_ARray(4)
    Dim ro%, X_C%, X_H%, Dr%
    Dim D As Worksheet, P As Worksheet
    Set P = Sheets("Permession")
    Set D = Sheets("Data")
With P
  Mon_ARray(0) = .[G7]: Mon_ARray(1) = .[C4]
  Mon_ARray(2) = .[C8]: Mon_ARray(3) = .[H8]
  Mon_ARray(4) = .[C9]
End With
With D
  Dr = Application.Max(.Range("a:a")) + 1
  ro = .Range("A3").CurrentRegion _
  .Columns(1).Rows.Count + 3
  .Cells(ro, 1) = Dr
  .Cells(ro, 1).Resize(, 11).Interior.ColorIndex = 35
  .Cells(ro, 2).Resize(, UBound(Mon_ARray) + 1) = _
  Mon_ARray
  Erase Mon_ARray
End With
X_C = Application.CountA(P.Range("C12:C18"))
X_H = Application.CountA(P.Range("H12:H18"))
D.Cells(ro, "H").Resize(X_C, 2).Value = _
P.Range("B12").Resize(X_C, 2).Value

D.Cells(ro, "J").Resize(X_H, 2).Value = _
P.Range("G12").Resize(X_H, 2).Value

End Sub

الملف مرفق

rouk.xlsm

[roukaf12]

مشكور أخي على سرعة الرد  جعله الله في ميزان حسناتك

ولكن انا بحاول اعمل كلير كونتنت مش عايز يشتغل ليه 

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

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

في نهاية الكود قبل End Sub هذا السطر

 With P
   Union(.[G7], .[C4], .[C8], .[H8], .[C9]) = vbNullString
 End With

 

[roukaf12]

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

لذا  نتقدم  بخالص الشكر والتقدير لشخصكم ولإدارة المنتدى التي طالما اتحفتنا بكل ما نحتاج اليه 

وإني لاعتذر عن تأخري بالرد لأني في العمل ولا استطيع الرد الا حينما اذهب للبيت