Sub TEST1()
Application.ScreenUpdating = False
Dim list1 As New Collection
On Error Resume Next
For Each Sheet In Worksheets
If sh.Name <> "data" Then
z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To z1
list1.Add Sheet.Range("A" & i), CStr(Sheet.Range("A" & i))
Next
End If
Next Sheet
Sheets("DATA").Range("A1") = "ID"
Sheets("DATA").Range("B1") = "Income"
For i = 1 To list1.Count
Sheets("DATA").Range("A" & i + 1) = list1.Item(i)
Next
Application.ScreenUpdating = True
End Sub
Sub TEST2()
k = 2
z2 = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To z2
Sum = 0
For Each Sheet In Worksheets
If Sheet.Name <> "data" Then
z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To z1
If Sheet.Range("A" & i) = Sheets("data").Range("A" & j) Then
Sum = Sum + Sheet.Range("b" & i)
End If
Next
End If
Next Sheet
Sheets("data").Range("b" & k) = Sum
k = k + 1
Next
End Sub
کامنت