Using for loop with variables in Excel

Question

In an Excel file, I want to do the following repetitive operations.

1) XX=sum(A1, A6, A11, A16, ..., A1001)

2) =(A1*B1+A6*B6+A11*B11+...+A1001*B1001)/XX

For large number of cells it is not possible to select cells by mouse. I would like to know if there is any way to use for and variables in Excel to complete that operation.

Answer 1

Product Sum Quotient

• What? Of course, it's made up.
• Carefully adjust the values in the constants section. It's set up for OP's example.

VBScript

Option Explicit

' 1) XX=sum(A1, A6, A11, A16, ..., A1001)

' 2) =(A1*B1+A6*B6+A11*B11+...+A1001*B1001)/XX

psQuotientTEST

Sub psQuotientTEST()

    Const sFirst = "A1"
    Const rCount = 201
    Const rIncrement = 5
    Const cCount = 2
    Const cIncrement = 1
    
    Dim xlApp: Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = False
    
        Dim wb: Set wb = .Workbooks.Open("C:\Test\Test.xlsx")
        Dim FirstCell: Set FirstCell = wb.Worksheets("Sheet1").Range(sFirst)
        
        Dim ps: ps = psQuotient(FirstCell, rCount, rIncrement, cCount, cIncrement)
        
        If IsEmpty(ps) Then
            MsgBox "Cannot compute.", vbCritical, "Failure"
        Else
            MsgBox "The result is " & ps, vbInformation, "Success"
        End If
        
        wb.Close False

        .Quit
    End With 
    
End Sub

Function psQuotient( _
        ByVal FirstCell, _
        ByVal rCount, _
        ByVal rIncrement, _
        ByVal cCount, _
        ByVal cIncrement)
    
    If FirstCell Is Nothing Then Exit Function
    If rCount < 1 Then Exit Function
    If rIncrement < 1 Then Exit Function
    If cCount < 1 Then Exit Function
    If cIncrement < 1 Then Exit Function
    
    Dim srCount: srCount = (rCount - 1) * rIncrement + 1
    Dim scCount: scCount = (cCount - 1) * cIncrement + 1
    
    Dim srg: Set srg = FirstCell.Resize(srCount, scCount)
    Dim Data
    If srCount + scCount = 2 Then
        ReDim Data(1, 1): Data(1, 1) = srg.Value ' poorly handled
    Else
        Data = srg.Value
    End If
        
    Dim rProduct
    Dim rProductSum
    Dim rSum
    Dim r, c
    
    For r = 1 To srCount Step rIncrement
        rSum = rSum + Data(r, 1)
        rProduct = 1
        For c = 1 To scCount Step cIncrement
            rProduct = rProduct * Data(r, c)
        Next
        rProductSum = rProductSum + rProduct
    Next
    
    If rSum <> 0 Then
        psQuotient = rProductSum / rSum
    End If

End Function

VBA

Option Explicit

' 1) XX=sum(A1, A6, A11, A16, ..., A1001)

' 2) =(A1*B1+A6*B6+A11*B11+...+A1001*B1001)/XX

Sub psQuotientTEST()

    Const sFirst As String = "A1"
    Const rCount As Long = 201
    Const rIncrement As Long = 5
    Const cCount As Long = 2
    Const cIncrement As Long = 1
    
    Dim FirstCell As Range: Set FirstCell = Range(sFirst)
    
    Dim ps As Variant
    ps = psQuotient(FirstCell, rCount, rIncrement, cCount, cIncrement)
    
    ' or just the following two lines instead of the complete preceding code:
    'Dim ps As Variant
    'ps = psQuotient(Range("A1"), 201, 5, 2, 1)
    
    If IsEmpty(ps) Then
        MsgBox "Cannot compute.", vbCritical, "Failure" ' from Alien(1979)
    Else
        MsgBox "The result is " & ps, vbInformation, "Success"
    End If

End Sub

Function psQuotient( _
    ByVal FirstCell As Range, _
    Optional ByVal rCount As Long = 1, _
    Optional ByVal rIncrement As Long = 1, _
    Optional ByVal cCount As Long = 1, _
    Optional ByVal cIncrement As Long = 1) _
As Variant
    
    If FirstCell Is Nothing Then Exit Function
    If rCount < 1 Then Exit Function
    If rIncrement < 1 Then Exit Function
    If cCount < 1 Then Exit Function
    If cIncrement < 1 Then Exit Function
    
    Dim srCount As Long: srCount = (rCount - 1) * rIncrement + 1
    Dim scCount As Long: scCount = (cCount - 1) * cIncrement + 1
    
    Dim srg As Range: Set srg = FirstCell.Resize(srCount, scCount)
    'Debug.Print "Range Address = " & srg.Address
    Dim Data As Variant
    If srCount + scCount = 2 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
    Else
        Data = srg.Value
    End If
        
    Dim rProduct As Double
    Dim rProductSum As Double
    Dim rSum As Double
    Dim r As Long, c As Long
    
    For r = 1 To srCount Step rIncrement
        rSum = rSum + Data(r, 1)
        rProduct = 1
        'Debug.Print "Sum = " & rSum
        For c = 1 To scCount Step cIncrement
            rProduct = rProduct * Data(r, c)
            'Debug.Print c & ". Product = " & rProduct
        Next c
        rProductSum = rProductSum + rProduct
        'Debug.Print "pSum = " & rProductSum
    Next r
    
    If rSum <> 0 Then
        psQuotient = rProductSum / rSum
        'Debug.Print "psQuotient = " & psQuotient
    End If

End Function