مطلوب نقل محتويات الخلية في b2 في الشيتات الى شيت واحد عموديا واحد تحت الاخر

[احمد النجارـر]

السلام عليكم

عندي جدول يتكون من عدد كثير من الشيتات وفي الخلية b2 من كل شيت يوجد اسم موظف المطلوب نقل الاسماء الموجودين في الخلية b2 من جميع الشيتات الى

شيت واحد في عمود واحد

Book1.rar

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

وعليكم السلام

جرب الكود التالي
 

Sub Test()
    Dim sh As Worksheet
    Dim iRow As Long
    
    iRow = 1 'Start Row
    Application.ScreenUpdating = False
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> "Sheet1" Then
                If sh.Range("B2").Value <> "" Then
                    Sheets("Sheet1").Range("A" & iRow).Value = sh.Range("B2").Value
                    iRow = iRow + 1
                End If
            End If
        Next sh
    Application.ScreenUpdating = True
End Sub

 

[طارق_طلعت]

الأستاذ العظيم ياسر

لو امكن عايز تعديل بسيط على الكود لينسخ القيم كمعادلة بحيث اذا تم تغير فى اى قيمة فى الخلية B2 فى اى شيت تتغير تلقائيا فى الشيت الأول

 

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

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

أخي الكريم طارق

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

مجرد رأي ونصيحة

[طارق_طلعت]

الأستاذ القدير ياسر

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

فأرجوا ان يتسع صدرك لتنفيذ المطلوب

 

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

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

جرب هذا الماكرو (يوضع في حدث الصفحة Sheet1)

Private Sub Worksheet_Activate()
Range("A:A").ClearContents
    For i = 2 To Sheets.Count
            Range("A" & i + 2).Formula = "=" & "Sheet" & i & "!$B$2"
     Next
End Sub