طلب .. إختصار معادلة ترحيل

[أبو إلياس السوري]

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

 

 

عند ترحيل البيانات (نظرا لكثرة البيانات) يجمد البرنامج ويأخذ وقت طويل لتنفيذ المهمة .. هل هناك أي حل ؟؟؟

 

 

طلب ثانوي ..:: هل من الممكن نسخ الخلية بدون تنسيق ..يعني أريد الترحيل بدون تنسيق ويكون نفس تنسيق القديم للخلية المرحل إليها....

1.rar

تم تعديل يوليو 9, 2015 بواسطه أبو إلياس السوري

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

عسى ان يكون المطلوب  بالنسبة للسرعة (الامر يستغرق 1.5 ثانية)

تم تبديل الملف لان الاصلي يحتوي على فيروس

ناجح راسب.rar

[أبو إلياس السوري]

عسى ان يكون المطلوب  بالنسبة للسرعة (الامر يستغرق 1.5 ثانية)

تم تبديل الملف لان الاصلي يحتوي على فيروس

يارك الله فيك ...

الملف الأصلي يحتي على فيروس ؟!!!! أنا أستخدم أفاست ماهو المضاد عندك أخي؟؟؟

الملف سريع ماشاء الله .... ولكن لو تلاحظ أن الملف الأساسي كان لا يرحل كل البيانات في كل الأعمدة بل يقوم بترحيل العمود الثاني والرابع والأخير .. والملف الذي أرفقته أنت يرحل كل الأعمدة ... فهل يمكن تعديله ؟؟؟

من ناحية السرعة سريع جدا .....بارك الله فيك ...

وبالنسبة للطلب الثاني .:: هل يمكننا النسخ بدون تنسيق ؟؟

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

لا توجد عندي نسخة للملف الاصلي لان الجهاز رفض ان يفتحه

[أبو إلياس السوري]

لا توجد عندي نسخة للملف الاصلي لان الجهاز رفض ان يفتحه

مش مشكلة  جزاك الله خيرا ..ومشكلة الفيروس غريبة

.. لعل وعسى أحد الأخوة يحل مكلة البطئ بنفس طريقة الملف الأصلي...

وهناك مشكلة أخرى أيضا في الملف الذي أرفقته أخي ... الملف الأصلي كان يرحل تلقائيا إلى اسم الصفحة المشابهة,,,

هل هناك طريقة للنسخ والترحيل بدون تنسيق ؟؟

تم تعديل يوليو 9, 2015 بواسطه أبو إلياس السوري

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

تم التعديل بدون تنسيق

1ناجح راسب.rar

[أبو إلياس السوري]

تم التعديل بدون تنسيق

طريقتك ممتازة وسريعة ونسخت بدون تنسيق ولكنني حاولت أن أطبقها على الملف الأصلي ولكن عبثا لم أستطع فهل هناك أحد يستطيع المساعدة؟؟؟؟

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

أخي الكريم

جرب الكود بهذا الشكل

Sub FilterData()
    Dim LR As Long, SH As Worksheet
    Application.ScreenUpdating = False
    For Each SH In ActiveWorkbook.Sheets
        If SH.Name <> "الرئيسية" Then
            With Sheets("الرئيسية")
                .Rows(3).AutoFilter
                .Rows(1).AutoFilter 8, "=" & SH.Name
                LR = .Range("A" & .Rows.Count).End(xlUp).Row
                If LR > 1 Then
                    Union(.Range("B2:B" & LR), .Range("E2:E" & LR), .Range("H2:H" & LR)).Copy
                    SH.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                End If
                .Rows(1).AutoFilter
            End With
        End If
    Next SH
    Application.ScreenUpdating = True
End Sub

تم التعديل على الكود الأصلي ليقوم بعمل نسخ للقيم فقط بدون نسخ التنسيقات

[أبو إلياس السوري]

 

أخي الكريم

جرب الكود بهذا الشكل

Sub FilterData()
    Dim LR As Long, SH As Worksheet
    Application.ScreenUpdating = False
    For Each SH In ActiveWorkbook.Sheets
        If SH.Name <> "الرئيسية" Then
            With Sheets("الرئيسية")
                .Rows(3).AutoFilter
                .Rows(1).AutoFilter 8, "=" & SH.Name
                LR = .Range("A" & .Rows.Count).End(xlUp).Row
                If LR > 1 Then
                    Union(.Range("B2:B" & LR), .Range("E2:E" & LR), .Range("H2:H" & LR)).Copy
                    SH.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                End If
                .Rows(1).AutoFilter
            End With
        End If
    Next SH
    Application.ScreenUpdating = True
End Sub

تم التعديل على الكود الأصلي ليقوم بعمل نسخ للقيم فقط بدون نسخ التنسيقات

 

إبداع كالعادة سلمت يداك وبارك الله في علمك وأعطاك علما من عنده