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

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


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





ضبط كود للترحيل

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



25-07-2020 02:27 مساء
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 

السلام عليكم  ورحمة الله وبركاته
حاولت جاهدا بالملف لضبط الترحيل لكن عند ترك اول خليه فارغه او ما بعدها  يقوم بترحيل البيانات خطآ
Mzc1MzY4MQ23232
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب 
 
 
  1.jpg   تحميل jpg 1.jpg مرات التحميل :(3)
الحجم :(103.148) KB
 
  ضبط كود الترحيل.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(59.154) KB


25-07-2020 02:46 مساء
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 231
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2149
عدد الإجابات: 28
 offline 
look/images/icons/i1.gif ضبط كود للترحيل
السلام عليكم ورحمة الله
اجعل الكود هكذا افضل
Sub tarheel()
Dim ws As Worksheet, sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
Set ws = Sheets("Rsd")
ws.Range("D10:D" & ws.Range("C" & Rows.Count).End(xlUp).Row).ClearContents
Set sh = Sheets("seer")
LR = sh.Range("C" & Rows.Count).End(xlUp).Row
Arr = sh.Range("A5:E" & LR).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1) Step 4
If Arr(i, 3) <> "" Then
p = p + 1
For j = 1 To 4
Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5))
Next

End If
Next
If p > 0 Then ws.Range("A10").Resize(p, UBound(Temp, 2)).Value = Temp
Application.ScreenUpdating = True
End Sub

25-07-2020 02:57 مساء
مشاهدة مشاركة منفردة [2]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ضبط كود للترحيل
جرب هذا الكود (اسهل و بدون المصفوفات)

Sub New_tarheel()
Dim ws As Worksheet, sh As Worksheet
Dim LR%, i%, m%
m = 10
Set ws = Sheets("Rsd")
Set sh = Sheets("seer")
ws.Range("D10", Range("D9").End(4)).ClearContents
LR = sh.Range("C" & Rows.Count).End(xlUp).Row
For i = 5 To LR Step 4
 ws.Cells(m, 4) = sh.Cells(i, 5)
 m = m + 1
Next
End Sub

 

25-07-2020 03:15 مساء
مشاهدة مشاركة منفردة [3]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif ضبط كود للترحيل
جزاك الله خيرا استاذ ابراهيم ..لكني اريد نقل العمود (E) فقط ...ولا اريد نقل الاسماء ولا ارقام الجلوس
تسلم استاذ سليم جزاك الله خيرا81

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

Sub New_tarhel()
Dim ws As Worksheet, sh As Worksheet
Dim LR%, i%
Dim Rg As Range

Set ws = Sheets("Rsd")
Set sh = Sheets("seer")
ws.Range("D10", Range("D9").End(4)).ClearContents
Set Rg = sh.Range("E5:E500").SpecialCells(2)
Rg.Copy
 ws.Cells(10, "D").PasteSpecial (12)
 Application.CutCopyMode = False
 ws.Cells(10, "D").Select
End Sub

25-07-2020 03:31 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif ضبط كود للترحيل
وعليكم السلام
جرب التالي
Sub Transfer_Data_In_Merged_Cells_From_Sheet_To_Another()
    Rem الإعلان عن المتغيرات ومنها مصفوفة سيكون عدد الأعمدة فيها 4 وتعبر عن النتائج
    Dim a(1 To 10000, 1 To 4), ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long
    Rem إيقاف اهتزاز الشاشة لتسريع الكود
    Application.ScreenUpdating = False
        Rem تعيين ورقة العمل التي يتم ترحيل البيانات منها
        Set ws = ThisWorkbook.Worksheets("seer")
        Rem تعيين ورقة العمل التي يتم ترحيل البيانات إليها
        Set sh = ThisWorkbook.Worksheets("Rsd")
        Rem تحديد رقم آخر صف به بيانات بناءً على العمود الثالث في ورقة البيانات
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        Rem حلقة تكرارية من الصف الخامس لآخر صف به بيانات وبتخطي 4 صفوف
        For r = 5 To lr Step 4
            Rem استخدام المتغير كعداد ويزيد في كل مرة بمقدار واحد
            m = m + 1
            Rem وضع المسلسل في أول عمود في المصفوفة
            a(m, 1) = m
            Rem وضع رقم الجلوس في العمود الثاني في المصفوفة
            a(m, 2) = ws.Cells(r, 2).Value  'Seat Number
            Rem وضع اسم الطالب في العمود الثالث في المصفوفة
            a(m, 3) = ws.Cells(r, 3).Value  'Student Name
            Rem وضع درجة الطالب في العمود الرابع في المصفوفة
            a(m, 4) = ws.Cells(r, 5).Value  'Mark
        Rem الانتقال للمجموعة التالية بعد تخطي 4 صفوف
        Next r
        Rem بدء التعامل مع الخلية في ورقة العمل التي سيتم ترحيل البيانات إليها
        With sh.Range("A10")
            Rem مسح النطاق بدايةً من الخلية وبامتداد 4 أعمدة مع استثناء أول 9 صفوف
            .Resize(Rows.Count - 9, 4).ClearContents
            Rem وضع نتائج المصفوفة في ورقة العمل الهدف
            .Resize(UBound(a, 1), UBound(a, 2)).Value = a
        End With
    Rem استرجاع خاصية اهتزاز الشاشة في نهاية الكود
    Application.ScreenUpdating = True
End Sub

25-07-2020 04:59 مساء
مشاهدة مشاركة منفردة [6]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif ضبط كود للترحيل
ربنا يبارك فيك استاذ ياسر ....جزاك الله خيرا111




الكلمات الدلالية
للترحيل ،


 










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

الساعة الآن 12:44 مساء