ارجو المساعدة فى كود استدعاء من اكثر من شيت

[ahmed88872]

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

ارجو المساعدة فى كود استدعاء من اكثر من شيت 

ويتغير بتغير البيانات

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

ahmed.xlsb

[محمد هشام.]

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

Sub Merger()                   
Dim srcWS As Variant, _
              WS As Worksheet, _
         I As Long, nCount As Integer
         
    Const rCrit  As String = "دمج"
    Const P  As String = "%"
    nCount = 4
   
   Set WS = Sheets("dmg1"): srcWS = Array("1", "2", "3")
   
  Application.ScreenUpdating = False    
 WS.Range("b4:f" & WS.Rows.Count).ClearContents

  For Each arr In Worksheets(srcWS)
    a = arr.Range("A2:G" & arr.Range("A" & arr.Rows.Count).End(xlUp).Row).Value
    
    tmp = arr.[C1]
    For I = 1 To UBound(a)
       If a(I, 2) > 0 And a(I, 5) = rCrit _
       And a(I, 6) > 0 Then
         
WS.Range("b" & nCount).Resize(1, 5).Value _
= Array((a(I, 1)), (a(I, 2)), (a(I, 6)), _
                   (a(I, 7) & P), tmp)
 nCount = nCount + 1
With WS.Range("B4:B" & WS.Cells(Rows.Count, "C").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-3")
    
    End With
   End If
  Next
Next arr
Application.ScreenUpdating = True
End Sub

وفي حدث ورقة (dmg1)

Private Sub Worksheet_Activate()
Merger
End Sub

 

 

 

ahmed v2.xlsb

تم تعديل مايو 11 بواسطه محمد هشام.

[ahmed88872]

تمام

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

تم تعديل مايو 11 بواسطه ahmed88872