Quick Macro Needed

[DaveH]

I need to go thru several worksheets and look for a specific set of text in
row A, and add up the values next to the text in row B and save that into a
group of cells in the current sheet.

I.e. Search criteria Dog, Cat, Bird, Snake.

Worksheet 1
Dog 12
Cat 1
Bird 3

Worksheet 2
Cat 1
Snake 2

Worksheet 3
Dog 1
Snake 10


Output to cells in current worksheet
Dog 13
Cat 2
Bird 3
Snake 12
Any help would be greatly appreciated.
Dave

 

[Don Guillett]

Use this macro assigned to a button or shape

Option Explicit
Sub sumeachsheet()
Dim n As Range
Dim ms As Long
Dim ws As Worksheet
Dim c, firstaddress

For Each n In Range _
("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
ms = 0
For Each ws In Worksheets
If ws.Name <> ActiveSheet.Name Then
With ws.Columns(1)
Set c = .Find(n, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
firstaddress = c.Address
Do
ms = ms + c.Offset(, 1)
Set c = .FindNext(c)
Loop While Not c Is Nothing And _
c.Address <> firstaddress
End If
End With
End If
Next ws
n.Offset(, 1) = ms
Next n
End Sub

 

[DaveH]

Don,
Thanks for the quick reply.
I could not get the macro to work correctly but I did have to move the info
in the sheets around for formatting.
The names are in column C of each sheet and the data is in column B. There
is other information in those columns that may be interfering with the macro.
I have a sheet with the names I’m looking for in column A if that would help.

 

[Don Guillett]

Your OP said col A for names and col B for numbers. That is the logical way
to do it. Why did you change. Anyway, modify to this
Option Explicit
Sub sumeachsheet()
Dim n As Range
Dim ms As Long
Dim ws As Worksheet
Dim c, firstaddress

For Each n In Range _
("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
ms = 0
For Each ws In Worksheets
If ws.Name <> ActiveSheet.Name Then
With ws.Columns(3)
Set c = .Find(n, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
firstaddress = c.Address
Do
ms = ms + c.Offset(,-1)
Set c = .FindNext(c)
Loop While Not c Is Nothing And _
c.Address <> firstaddress
End If
End With
End If
Next ws
n.Offset(, 1) = ms
Next n
End Sub

 

[DaveH]

That is working with the exception that it seems to not pick up the last
couple of names in the list. The only differences I can see between the cells
are that the names consist of two words rather than one single word. Would
that keep the macro from continuing?

 

[Don Guillett]

If desired, send your file to my address below along with this msg and
a clear explanation of what you want and before/after examples.

 

[keiji kounoike]

This is another approach.

Sub sumsheets()
'Change const below according to your layout
Const curname = "A" 'Column's name of name in output worksheet
Const curnum = "B" 'Column's name of sum in output worksheet
Const colname = "C" 'column's name of name in data worksheets
Const colnum = "B" 'column's name of number in data worksheets

Dim acsh As Worksheet, sh As Worksheet
Dim rng1 As Range, rng2 As Range
Dim i As Long, n As Long
Dim strformula As String
Dim arlist, tmp

Set acsh = ActiveSheet
arlist = Range(Cells(1, curname), Cells(1, curname).End(xlDown)).Value
For i = 1 To UBound(arlist, 1)
For Each sh In Worksheets
If sh.Name <> ActiveSheet.Name Then
With sh
n = .Cells(1, colname).End(xlDown).Row
Set rng1 = .Range(.Cells(1, colname), .Cells(n, colname))
Set rng2 = .Range(.Cells(1, colnum), .Cells(n, colnum))
strformula = strformula & "+sumproduct(--(" & rng1.Parent.Name _
& "!" & rng1.Address & "=""" & arlist(i, 1) & """)," _
& rng2.Parent.Name & "!" & rng2.Address & ")"
End With
End If
Next
tmp = acsh.Cells(i, curnum).Value
acsh.Cells(i, curnum).Formula = "=" & strformula
If VarType(tmp) = vbString Then
acsh.Cells(i, curnum).Value = tmp
End If
strformula = ""
Next
End Sub

Keji

 

[DaveH]

I just wanted to say thanks. I did get the code to work.

 

[Don Guillett]

The archives want to see your final solution.