Macro to sum selected cells in a row and repeat for all rows in a column with values

[KlayontKress]

To all,


I'm looking for a macro that will allow the user to select multiple cells (up to 5) in a row (Lets say E10 and G10) and then add the sum of those two cells into the left most cell selected (this will usually be the first cell selected but it's possible the user will select the calues in a different order than left to right (we can standardize if we need to)).

I then need the macro to go through and repeat this for every row in a column with values use the same relative positions as the first series of values selected.


For example, from the chart below, lets say I select D4, E4,G4,M4. I want to placed the summed value of these into cell D4 (not the formula for the sum but the actual value). In this case it would be 23. I then need the macro to remember that the left most column is "D" and that the initial values selected were in relative positions of +0, 1, 3, and 9 to go through and do this same calculation for every row in column D with a value and put in the summed value. The macro would then deleted all of the columns for the values selected except for the left most one where the summed values went.


The values in column "D" would end up being:

D4=23
D6=27
D8=31
D10=35
D12=39

and columns E,G, and M in the column below would be deleted.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]group[/TD]
[TD]style[/TD]
[TD][/TD]
[TD]Room 1[/TD]
[TD]Room 2[/TD]
[TD]Room 3[/TD]
[TD]Room 4[/TD]
[TD]Room 5[/TD]
[TD]Room 6[/TD]
[TD]Room 7[/TD]
[TD]Room 8[/TD]
[TD]Room 9[/TD]
[TD]Room 10[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]base[/TD]
[TD]blah[/TD]
[TD][/TD]
[TD]10[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]level 1[/TD]
[TD]blah blah[/TD]
[TD][/TD]
[TD]11[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]level 2[/TD]
[TD]blah blah blah[/TD]
[TD][/TD]
[TD]12[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]level 3[/TD]
[TD]blah blah blah blah[/TD]
[TD][/TD]
[TD]13[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD]12[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]level 4[/TD]
[TD]blaah[/TD]
[TD][/TD]
[TD]14[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD]12[/TD]
[TD]13[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Thanks for your help,

 

[RCBricker]

this should get you started. Only thing it does not do is delete the columns. I have a meeting so cant work on that.

Sub FORS()

Dim wb As Workbook
Dim ws As Worksheet
Dim lngROW As Long, lngCOL As Long
Dim cell1 As Range, cell2 As Range, cell3 As Range, cell4 As Range, cell5 As Range
Dim int1 As Integer, int2 As Integer, int3 As Integer, int4 As Integer, int5 As Integer, intST As Integer, intROW As Integer
Dim rng As Range, cell As Range
Dim dSUM As Double
Dim i As Variant

Set wb = ThisWorkbook
On Error Resume Next
Set cell1 = Application.InputBox(Prompt:="Please select a cell", Title:="cell selection", Type:=8)
On Error GoTo 0
If cell1 Is Nothing Then
    MsgBox "User failed to select a cell.  Please start again"
    End
End If
int1 = cell1.Column
intROW = cell1.Row
Set ws = ActiveSheet

lngCOL = ws.Cells.Find(What:="*", _
        after:=ws.Cells(1), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Column





On Error Resume Next
Set cell2 = Application.InputBox(Prompt:="Please select a cell", Title:="cell selection", Type:=8)
On Error GoTo 0
If cell2 Is Nothing Then
    MsgBox "User failed to select a cell.  Please start again"
    End
End If
If cell2.Row <> intROW Then
    MsgBox "User selected a cell on different row.  Please start again"
    End
Else
    int2 = cell2.Column
End If
On Error Resume Next
Set cell3 = Application.InputBox(Prompt:="Please select a cell", Title:="cell selection", Type:=8)
On Error GoTo 0
If cell3 Is Nothing Then
    MsgBox "User failed to select a cell.  Please start again"
    End
End If
If cell3.Row <> intROW Then
    MsgBox "User selected a cell on different row.  Please start again"
    End
Else
    int3 = cell3.Column
End If
On Error Resume Next
Set cell4 = Application.InputBox(Prompt:="Please select a cell", Title:="cell selection", Type:=8)
On Error GoTo 0
If cell4 Is Nothing Then
    MsgBox "User failed to select a cell.  Please start again"
    End
End If
If cell4.Row <> intROW Then
    MsgBox "User selected a cell on different row.  Please start again"
    End
Else
    int4 = cell4.Column
End If
On Error Resume Next
Set cell5 = Application.InputBox(Prompt:="Please select a cell", Title:="cell selection", Type:=8)
On Error GoTo 0
If cell5 Is Nothing Then
    MsgBox "User failed to select a cell.  Please start again"
    End
End If
If cell5.Row <> intROW Then
    MsgBox "User selected a cell on different row.  Please start again"
    End
Else
    int5 = cell5.Column
End If

intST = WorksheetFunction.Min(int1, int2, int3, int4, int5)

dSUM = cell1 + cell2 + cell3 + cell4 + cell5
ws.Cells(intROW, intST).Value = dSUM

End Sub