Sum non adjacent cells with criteria

[sooshil]

Hello

I have data to analyse game result as follows.
Every team has to play twice with the same opponent yielding Score1 and Score2.
I have to add total score of each player on a table 2 shown below.
The main problem is the number of team will be changing. If a team is added then every team will also play with the new team.
So, I want to dynamically add those team scores no matter how many times they played.
I have list of team in another sheet and this first data is dynamically generated based upon the teams listed on the other sheet.
Since the player can be added or removed, the number of scores we need to take will also be changed. That means the position(cell address) of a player in the sheet changes as a player is added or removed.
May be I am explaining more than required. If required more information, I am ready here.

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

1

John Vs Jane

John Vs Joseph

John Vs Regina

2

Teams

Score1

Score2

Tie?

N/R?

Teams

Score1

Score2

Tie?

N/R?

Teams

Score1

Score2

Tie?

N/R?

3

John

25

36

John

35

29

John

38

42

4

Jane

28

29

Joseph

46

32

Regina

42

33

5

6

Jane Vs Joseph

Jane Vs Regina

Joseph Vs Regina

7

Teams

Score1

Score2

Tie?

N/R?

Teams

Score1

Score2

Tie?

N/R?

Teams

Score1

Score2

Tie?

N/R?

8

Jane

25

52

Jane

40

36

Joseph

42

36

9

Joseph

36

41

Regina

32

51

Regina

44

41

10

<colgroup><col span="2"><col><col><col span="2"><col span="7"><col><col span="6"></colgroup><tbody>
</tbody>

	Score1	Score2
John
Jane
Joseph
Regina

<tbody>
</tbody>

 

[DanteAmor]

Just put your equipment on sheet2 as shown below.

Sheet2
<table border="1" cellspacing="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:76.04px;" /><col style="width:76.04px;" /><col style="width:76.04px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td > </td><td >Score1</td><td >Score2</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >John</td><td style="text-align:right; ">98</td><td style="text-align:right; ">107</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >Jane</td><td style="text-align:right; ">93</td><td style="text-align:right; ">117</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >Joseph</td><td style="text-align:right; ">124</td><td style="text-align:right; ">109</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td >Regina</td><td style="text-align:right; ">118</td><td style="text-align:right; ">125</td></tr></table>

Run this macro

Note: Change Sheet1 and Sheet2 by the name of your sheets.

Sub [B][COLOR=#0000ff]Scores[/COLOR][/B]()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim r As Range, f As Range, cell As String, c As Range
  
  Set sh1 = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
  Set sh2 = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")
  Set r = sh1.UsedRange
  
  For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c.Value, , xlValues, xlWhole)
    If Not f Is Nothing Then
        cell = f.Address
        Do
            c.Offset(, 1).Value = c.Offset(, 1).Value + f.Offset(, 1).Value
            c.Offset(, 2).Value = c.Offset(, 2).Value + f.Offset(, 2).Value
            Set f = r.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  MsgBox "End  "
End Sub

HOW TO INSTALL MACROs
------------------------------------
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (Scores) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

 

[sooshil]

Hi Dante

Thanks for the response. I really appreciative your effort. That adds up the scores but there is a problem.
For the same set of players, no matter how many we run the macro, the total scores should remain same. But here, If we run the macro more than once, the total keeps increasing. Which is not what I want.

Thank you again.

 

[DanteAmor]

Try this please:

Sub Scores()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim r As Range, f As Range, cell As String, c As Range
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.UsedRange
Sh2.range(sh2.cells(2,2), sh2.cells(rows.count, columns.count)).clearcontents
  
  For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
    Set f = r.Find(c.Value, , xlValues, xlWhole)
    If Not f Is Nothing Then
        cell = f.Address
        Do
            c.Offset(, 1).Value = c.Offset(, 1).Value + f.Offset(, 1).Value
            c.Offset(, 2).Value = c.Offset(, 2).Value + f.Offset(, 2).Value
            Set f = r.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  MsgBox "End  "
End Sub

 

[sooshil]

Hi Dante

Thank you so much.
It worked.
I am not good at VBA. Can you let me know, if I want to change the resulting table anywhere I want (in Sheet2), then where do I need to change the VBA?

 

[DanteAmor]

For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))

Change "A" by the new column
Change 2 of "A2" by the initial row

 

[sooshil]

For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))

Change "A" by the new column
Change 2 of "A2" by the initial row

Thank you so much.

 

[DanteAmor]

Thank you so much.

Im glad to help you, thanks for the feedback.

 

[sooshil]

Hi Dante

Thank you again for your support so far. Now, my requirement for the same problem is changed. Actually I couldn't realize before that I need 'For' and 'Against' column too.
I need to get data in the second table as follows.

	A	B	C
1		Score1		Score2
2		For	Against	For	Against
3	John
4	Jane
5	Joseph
6	Regina

<tbody>
</tbody>

'For' for a player, lets say for John is sum of all the score that John has scored
'Against' for him is the sum of all the scores that his opponents scored against him.

Thank you so much Dante.

 

[DanteAmor]

Try this


To change the resulting table anywhere update this line: Set r2 = sh2.Range("A3", sh2.Range("A" & Rows.Count).End(xlUp))

Sub Scores()
  Dim sh1 As Worksheet, sh2 As Worksheet, r As Range, r2 As Range
  Dim f As Range, cell As String, c As Range, n As Long
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.UsedRange
[COLOR=#0000ff]  Set r2 = sh2.Range("A3", sh2.Range("A" & Rows.Count).End(xlUp))[/COLOR]
  
  r2.Offset(0, 1).Resize(r2.Rows.Count, Columns.Count - r2.Cells(1, 1).Column).ClearContents
  For Each c In r2
    Set f = r.Find(c.Value, , xlValues, xlWhole)
    If Not f Is Nothing Then
        cell = f.Address
        Do
            c.Offset(, 1).Value = c.Offset(, 1).Value + f.Offset(, 1).Value
            c.Offset(, 3).Value = c.Offset(, 3).Value + f.Offset(, 2).Value
            If f.Offset(1, 1).Value = "" Then n = -1 Else n = 1
            c.Offset(, 2).Value = c.Offset(, 2).Value + f.Offset(n, 1).Value
            c.Offset(, 4).Value = c.Offset(, 4).Value + f.Offset(n, 2).Value
            Set f = r.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
  MsgBox "End  "
End Sub