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

[جمال محمود محمد]

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

 

أرجو المساعدة بكود نسخ أعمدة معينة من ورقة 1 لورقة 2 مرفق مثال أريد نقل E - F - I - A للورقة 2

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم جمال

يرجى تغيير اسم الظهور للغة العربية ، ويرجى إرفاق الملف

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

جرب هذا الملف ربما يكون المطلوب

 

Copy_spec_col.rar

[جمال محمود محمد]

16 دقائق مضت, سليم حاصبيا said:

صباح الخير أخى سليم

ومشكور على الاستجابة 

بالنسبة للظهور يظهر بالانجليزي لانني أسجل دخول بالفيس بوك

بالنسبة للملف المرفق أرجو المساعدة فى الاتى :-

1/ نقل بيانات Normal - Oil - Accident - Washing  فقط الاعمدة من 3 الى 6

2/ يكون التسلسل تلقائي عند اضافة اى قيمة فى الخلية المقابلة

3/ اضافة عبارة تم التقدير فى العمود الاخير تلقائيا

 

16 دقائق مضت, سليم حاصبيا said:

 

 

 

Test5.rar

[جمال محمود محمد]

فى انتظار الرد

[جمال محمود محمد]

فى انتظار الرد

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

تم العمل حسب المطلوب

فقط اضغط (اعجاب)

 

copy_rng.rar

[ياسر خليل أبو البراء]

أخي الكريم جمال محمود

في ورقة العمل المسماة "All" قم بحذف الصفوف كلها بداية من الصف السادس إلى آخر صف .. وحول الجدول إلى نطاق عادي ثم ضع الكود التالي في موديول عادي ثم نفذ الأمر ..

Sub YasserKhalil()
    Dim Ws As Worksheet, Sh As Worksheet
    Dim LR As Long, Last As Long

    Set Sh = Sheets("All")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With Sh
            .Range("A6:G10000").Clear
    
            'حلقة تكرارية لكل أوراق العمل لجلب البيانات من الأعمدة المحددة
            For Each Ws In ThisWorkbook.Worksheets
                If Ws.Name <> "All" Then
                    LR = Ws.Cells(Rows.Count, 1).End(xlUp).Row
                    Last = .Cells(Rows.Count, "B").End(xlUp).Row
    
                    Ws.Range("E2:I" & LR).Copy
                    .Range("B" & Last + 1).PasteSpecial xlPasteValues
                End If
            Next Ws
    
            Last = .Cells(Rows.Count, "B").End(xlUp).Row + 1
            
            'وضع عبارة "تم التقدير" في العمود السابع
            .Range("G6:G" & Last).Value = "تم التقدير"
    
            'ترقيم العمود الأول
            With .Range("A6:A" & Last + 1)
                .Formula = "=IF(B6="""","""",ROW()-5)"
                .Value = .Value
            End With
    
            'دمج خلايا المجموع ووضع المعادلة في الخلايا المدمجة
            With .Range("A" & Last & ":B" & Last)
                .Merge
                .Value = "المجموع"
            End With
    
            With .Range("C" & Last & ":G" & Last)
                .Merge
                .Formula = "=SUM(F6:F" & Last - 1 & ")"
            End With
    
            'تسطير جدول البيانات التي تم جلبها
            .Range("A5").CurrentRegion.Borders.Value = 1
    
            'تنسيق نطاق البيانات
            With .Range("A5").CurrentRegion.Offset(1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
        End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

في الكود يوجد بعض التعليقات التي تساعدك في فهم الكود

تقبل تحياتي

 

[جمال محمود محمد]

الاخوان الأفاضل سليم حاصبيا وياسر خليل أبو البراء

لكم التحايا والتقدير على إستجابتكم السريعة 

لقد كنتم عند حسن ظنى بكم عندما طلبت مساعدتكم

عاجز عن الشكر والتقدير وإن شاء الله فى ميزان حسناتكم

قسما بالله قمة الابداع كل المطلوب وجدته فى إجاباتكم الشافية والتى سوف تساعدنى كثيرا فى مجال عملي

لقد سهلتم لى العمل وتقليل الجهود التى كنت أبذلها فى سبيل إعداد هذا التقرير 

 

شكرا سليم شكرا ياسر

 

ومزيدا من التقدم والازدهار

 

 

 

 

[جمال محمود محمد]

18 ساعات مضت, ياسر خليل أبو البراء said:

أخي الكريم جمال محمود

في ورقة العمل المسماة "All" قم بحذف الصفوف كلها بداية من الصف السادس إلى آخر صف .. وحول الجدول إلى نطاق عادي ثم ضع الكود التالي في موديول عادي ثم نفذ الأمر ..

Sub YasserKhalil()
    Dim Ws As Worksheet, Sh As Worksheet
    Dim LR As Long, Last As Long

    Set Sh = Sheets("All")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With Sh
            .Range("A6:G10000").Clear
    
            'حلقة تكرارية لكل أوراق العمل لجلب البيانات من الأعمدة المحددة
            For Each Ws In ThisWorkbook.Worksheets
                If Ws.Name <> "All" Then
                    LR = Ws.Cells(Rows.Count, 1).End(xlUp).Row
                    Last = .Cells(Rows.Count, "B").End(xlUp).Row
    
                    Ws.Range("E2:I" & LR).Copy
                    .Range("B" & Last + 1).PasteSpecial xlPasteValues
                End If
            Next Ws
    
            Last = .Cells(Rows.Count, "B").End(xlUp).Row + 1
            
            'وضع عبارة "تم التقدير" في العمود السابع
            .Range("G6:G" & Last).Value = "تم التقدير"
    
            'ترقيم العمود الأول
            With .Range("A6:A" & Last + 1)
                .Formula = "=IF(B6="""","""",ROW()-5)"
                .Value = .Value
            End With
    
            'دمج خلايا المجموع ووضع المعادلة في الخلايا المدمجة
            With .Range("A" & Last & ":B" & Last)
                .Merge
                .Value = "المجموع"
            End With
    
            With .Range("C" & Last & ":G" & Last)
                .Merge
                .Formula = "=SUM(F6:F" & Last - 1 & ")"
            End With
    
            'تسطير جدول البيانات التي تم جلبها
            .Range("A5").CurrentRegion.Borders.Value = 1
    
            'تنسيق نطاق البيانات
            With .Range("A5").CurrentRegion.Offset(1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
        End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

في الكود يوجد بعض التعليقات التي تساعدك في فهم الكود

تقبل تحياتي

 

الاخ  ياسر خليل أبو البراء

 

لك التحية

 

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

 

مع خالص شكري وتقديري

 

 

[ياسر خليل أبو البراء]

غير سطر الحلقة التكرارية إلى السطر التالي لتحدد الأوراق المطلوبة

For Each Ws In Worksheets(Array("Washing", "Accident"))

 

[جمال محمود محمد]

23 دقائق مضت, ياسر خليل أبو البراء said:

غير سطر الحلقة التكرارية إلى السطر التالي لتحدد الأوراق المطلوبة

For Each Ws In Worksheets(Array("Washing", "Accident"))

 

تسلم الايادي الف الف شكر