CODEWITHSUNDEEP
excelvba
user3666237
user3666237

Reputation: 153

How to a apply a macro that's for one cell to multiple cells

I have the following code that add the same cell based on the worksheet name, here's the code:

Sub Addem()
Dim ws As Worksheet
x = 0
For Each ws In Worksheets
If ws.Name Like "*Fvar" Then
    x = x + ws.Range("G12").Value
End If
Next ws
Sheets("Summary-Fvar2").Range("G12").Value = x
End Sub

How can I format this macro to apply it to several cells location separately? (H12, N12, H33, N33 etc...)

When I tried defining the range name and adding all the cell locations I wanted to apply it to it sum every cell in the range.

Upvotes: 0

Views: 58

Answers (2)

Storax
Storax

Reputation: 12167

I would apply a formula like that. This code replaces your Sub Addem

Sub AddCell(ByVal myCell As String, ByVal target As Range, ByVal pattern As String)

    Dim ws As Worksheet
    Dim myFormula As String

        For Each ws In Worksheets
            If ws.Name Like pattern Then
                myFormula = myFormula & ws.Name & "!" & myCell & ","
            End If
        Next

        myFormula = Left(myFormula, Len(myFormula) - 1)
        target.Formula = "=SUM(" & myFormula & ")"

End Sub

Sub TestIt()
     AddCell "G12", Sheets("Summary-Fvar2").Range("G12"), "Fav*"    
End Sub

The next code is for an array of cells

Sub AddCellV(ByVal vCell As Variant, ByVal target As Range, ByVal pattern As String)
            Dim ws As Worksheet

        Dim myFormula As String
        Dim i As Long
            For i = LBound(vCell) To UBound(vCell)
                For Each ws In Worksheets
                    If ws.Name Like pattern Then
                        myFormula = myFormula & ws.Name & "!" & vCell(i) & ","
                    End If
                Next
            Next

            myFormula = Left(myFormula, Len(myFormula) - 1)
            target.Formula = "=SUM(" & myFormula & ")"

End Sub

Sub TestIt()                
      AddCellV Array("G12", "H12", "N12", "H33", "N33"), Sheets("Summary-Fvar2").Range("G12"), "Fav*"                
End Sub

By the comment of the TO AddCell needs to applied multiple times like that

Sub AddCellMultiple(ByVal vCell As Variant, _
                            ByVal targetSh As Worksheet, _
                            ByVal pattern As String)

    Dim i As Long
    For i = LBound(vCell) To UBound(vCell)
        AddCell vCell(i), targetSh.Range(vCell(i)), pattern
    Next

End Sub


Sub TestMultiple()
    AddCellMultiple Array("G12", "H12", "N12", "H33", "N33"), Sheets("Summary-Fvar2"), "Fav*"
End Sub

Upvotes: 1

SJR
SJR

Reputation: 23081

If you want the cells added separately, you could cycle through an array, viz

Sub Addem()

Dim ws As Worksheet, x() As Long, v, i As Long

v = Array("G12", "H12", "N12", "H33", "N33") 'amend to suit
ReDim x(UBound(v))

For Each ws In Worksheets
    If ws.Name Like "*Fvar" Then
        For i = LBound(v) To UBound(v)
            x(i) = x(i) + ws.Range(v(i)).Value
        Next i
    End If
Next ws

For i = LBound(v) To UBound(v)
    Sheets("Summary-Fvar2").Range(v(i)).Value = x(i)
Next i

End Sub

Upvotes: 1

Related Questions