أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





كود ترحيل صف من شيت لأخر بناء على قيمة خلية

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


موضوع مغلق


28-03-2021 09:26 صباحا
aelsheikh
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 12-03-2020
رقم العضوية : 18494
المشاركات : 7
الجنس : ذكر
تاريخ الميلاد : 24-10-1987
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 14
 offline 

السلام عليكم ورحمة الله وبركاته

كل عام وانتم بخير وجزاكم الله خيرا مقدما على مساعدتكم

في الشيت المرفق المطلوب كود VBA لترحيل بيانات الصف من شيت إلى شيت أخر في نفس الملف بناء على قيمة خلية في عمود معين ومن ثم إدارج تاريخ الترحيل في العمود المجاور في الشيت المرحل إليه. لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  test.rar   تحميل rar مرات التحميل :(16)
الحجم :(17.792) KB



أفضل إجابة مقدمة من salim وهي:
جرب هذا الكود

Option Explicit
Sub trans_data()
Const mot$ = "DELIVERED"
Dim Source_Sheet As Worksheet
Dim Target_Sheet As Worksheet
Dim Rs_Copy As Range, Cel As Range
Dim dic As Object, ky
Dim Rs%, n%, Rt%
Dim arr As Variant

Set Source_Sheet = Sheets("ONGOING")
Set Target_Sheet = Sheets("DELIVERED")
Set dic = CreateObject("Scripting.Dictionary")
Set Rs_Copy = Source_Sheet.Range("a2").CurrentRegion
Rs = Rs_Copy.Rows.Count
Rt = Target_Sheet.Cells(Rows.Count, 1).End(3).Row + 1
If Rt = 2 Then Rt = 3
If Rs = 1 Then Exit Sub
Set Rs_Copy = Rs_Copy.Offset(1).Resize(Rs - 1)
For Each Cel In Rs_Copy.Columns(15).Cells
 If UCase(Cel) = mot Then
 n = n + 1
   arr = Application.Transpose(Cel.Offset(, -13).Resize(, 15))
   arr = Join(Application.Transpose(arr), "*")
   dic(n) = arr
 End If
 Next
 If dic.Count Then
    For Each ky In dic.keys
      Target_Sheet.Cells(Rt, 1) = ky
      Target_Sheet.Cells(Rt, 2).Resize(, 15) = _
       Split(dic(ky), "*")
      Target_Sheet.Cells(Rt, "Q") = Date
      Rt = Rt + 1
    Next
 End If
 
End Sub


الملف مرفق
عرض الإجابة




28-03-2021 12:07 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود ترحيل صف من شيت لأخر بناء على قيمة خلية
جرب هذا الكود

Option Explicit
Sub trans_data()
Const mot$ = "DELIVERED"
Dim Source_Sheet As Worksheet
Dim Target_Sheet As Worksheet
Dim Rs_Copy As Range, Cel As Range
Dim dic As Object, ky
Dim Rs%, n%, Rt%
Dim arr As Variant

Set Source_Sheet = Sheets("ONGOING")
Set Target_Sheet = Sheets("DELIVERED")
Set dic = CreateObject("Scripting.Dictionary")
Set Rs_Copy = Source_Sheet.Range("a2").CurrentRegion
Rs = Rs_Copy.Rows.Count
Rt = Target_Sheet.Cells(Rows.Count, 1).End(3).Row + 1
If Rt = 2 Then Rt = 3
If Rs = 1 Then Exit Sub
Set Rs_Copy = Rs_Copy.Offset(1).Resize(Rs - 1)
For Each Cel In Rs_Copy.Columns(15).Cells
 If UCase(Cel) = mot Then
 n = n + 1
   arr = Application.Transpose(Cel.Offset(, -13).Resize(, 15))
   arr = Join(Application.Transpose(arr), "*")
   dic(n) = arr
 End If
 Next
 If dic.Count Then
    For Each ky In dic.keys
      Target_Sheet.Cells(Rt, 1) = ky
      Target_Sheet.Cells(Rt, 2).Resize(, 15) = _
       Split(dic(ky), "*")
      Target_Sheet.Cells(Rt, "Q") = Date
      Rt = Rt + 1
    Next
 End If
 
End Sub


الملف مرفق
 
 
  test.xlsm   تحميل xlsm مرات التحميل :(32)
الحجم :(75.566) KB




الكلمات الدلالية
قيمة ، خلية ، ترحيل ، لأخر ، بناء ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:28 مساء