نسخ التنسيقات

[ناصر سعيد]

هذا ملف بسيط  وبه كود مفيد

ولكني اريد ان يتم اثناء التسطير ياخذ جميع التنسيقات

الموجوده بالخلايا ذات اللون الاحمر

الى كل الصفوف

جزاكم الله خيرا

 

استدعاء اعمد معينه لاعمده اخرى معينه.rar

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

السلام عليكم أخي العزيز ناصر

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

تقبل الله منا ومنكم صالح الأعمال

[ناصر سعيد]

اشكرك استاذ ياسر وكل عام وانت بخير

========

هل يمكن ان تزيد الموضوع اثراء ؟

جزاك الله خيرا

[قصي]

1 ساعه مضت, ناصر سعيد said:

اشكرك استاذ ياسر وكل عام وانت بخير

========

هل يمكن ان تزيد الموضوع اثراء ؟

جزاك الله خيرا

هل يمكن ان تزيد الموضوع اثراء ؟

جزاك الله خيرا

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

 

 

ولمن يريد الصورة مجمعة في ملف واحد يمكن تحميله من الرابط التالي 

من هنا

[ناصر سعيد]

جزاك الله خيرا استاذ ياسر ... وبعد :

في السطر التاني من الكود انت حددت النطاق .. ولكن النطاق دائما متغير يزيد وينقص

ايه الحل ؟

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

للنطاق المتغير يمكن الاعتماد على رقم آخر صف به بيانات وقد تناولت طريقة الحصول على رقم آخر صف به بيانات في الفيديو التالي

 

[ناصر سعيد]

'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'تم هذا الكود في 15/2/2017
    Sub استدعاء()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim cr      As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
    Dim ws As Worksheet
    Dim sh As Worksheet
    Set ws = Sheets("Sheet1")
    Set sh = Sheets("Sheet2")
    '= = = = = = = = = = = =
    ' شيت الهدف والمدى المطلوب مسحه
    sh.Range("B7:AJ10000").ClearContents
    
        ' اسم ورقة المصدر
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
            'متغير اسم ورقة المصدرومدى البيانات بها
    arr = ws.Range("A7:EF" & lr).Value
    
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
    'ارقام الاعمده المطلوب نقلها
    cr = Array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73)
    j = 1

    For i = LBound(arr, 1) To UBound(arr, 1)
    
   ' المعيار او الشرط الذي نبحث به ورقم عمود المعيار
        If arr(i, 135) Like "*" & "نا*" & "*" Then
            temp(j, 1) = j
            For c = LBound(cr) To UBound(cr)
                temp(j, c + 2) = arr(i, cr(c))
            Next c
            j = j + 1
        End If
    Next i
    
    ' اسم شيت الهدف
    With sh
    
        .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp
        
        'سطر لمسح التسطير
        .Range("B7:AJ" & Rows.Count).Borders.Value = 0
        
        'سطر لاضافة التسطير
        .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1
        PasteSpecial Paste:=xlPasteFormats
       
    End With
End Sub

لماذا لاتعمل مع اضافه نسخ التنسيقات ؟

جزاكم الله خيرا

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

أين الجزء الذي فيه نسخ التنسيق .. يفترض أنك تريد نسخ التنسيق من نطاق أو خلايا محددة باستخدام الأمر Copy أين هو في الكود؟

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

PasteSpecial Paste:=xlPasteFormats

 

[ناصر سعيد]

        'سطر لاضافة التسطير
        .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1


        Range("B7:AJ7").Copy
       .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
    Range("F7").Select

تمام شكرا على تسلسل الشرح لكم حتى الافاده

تمت بنجاح وتظهر اثناء النسخ شاشه زرقاء سريعه ... هل يمكن ازاله هذه الشاشه بامر برمجي

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

لربما بسبب اهتزاز الشاشة وهنا يمكن استخدام السطر التالي في بداية الكود بعد الإعلان عن المتغيرات

Application.ScreenUpdating=False

وفي نهاية الكود نفس السطر مع تغيير القيمة False إلى True

[ناصر سعيد]

حفظك ربنا ورعاك استاذ ياسر

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

بارك الله فيك أخي العزيز ناصر وجزيت خيراً على دعائك الطيب .. والحمد لله الذي بنعمته تتم الصالحات