Quick Macro Needed

  • Thread starter Thread starter DaveH
  • Start date Start date
D

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
 
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
 
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.
 
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
 
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?
 
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.
 
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
 
Back
Top