وعليكم السلام ورحمة الله تعالى وبركاته
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