Taking multiple arrays to multiply different ranges in excel sheet

I am trying to multiply different ranges in an excel sheet and running them when the multiplier value changes.
Sheet 1 has :

Sheet 2 has:

Column A2 : "5%" - Percentage value
Column A4 : "10%" - Percentage value

I want to increase or decrease the value of B and C columns with 5% and D with 10%. Further, which will change and refresh the whole table in Sheet 1 when the values in Sheet 2 are changed.

Here is the code I am using and it is working for B and C rows but not for the second array:

    With Sheet1
        Dim LastRow As Long
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    
         Dim arr() As Variant
    Dim arr2() As Variant
    arr = .Range("B2:C" & LastRow).Value
    arr2 = .Range("D2:D" & LastRow).Value
End With
    GA1 = 1 + Sheet2.Range("A4").Value
    If Sheet2.Range("A4").Value <= 0 Then GA1 = 1
         
         
    GA2 = 1 + Sheet2.Range("A2").Value
    If Sheet2.Range("A2").Value <= 0 Then GA2 = 1
    
       
     Dim i As Long
     Dim m As Long
    
    For m = LBound(arr2, 1) To UBound(arr2, 1)
    arr2(m, 1) = arr2(m, 1) * GA1
    Next
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        arr(i, 1) = arr(i, 1) * GA2
        arr(i, 2) = arr(i, 2) * GA2
    Next
    
    Sheet1.Range("B2").Resize(UBound(arr, 1), 2).Value = arr
    Sheet1.Range("D2").Resize(UBound(arr2)).Value = arr2

String method:

Sub IncreaseRangeTEST()

    Const SRC_FIRST_CELL As String = "A2"
    Const SRC_COLS_LIST As String = "B:C,D"
    Const LKP_CELLS_LIST As String = "A2,A4"
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
       
    Set wb1 = ActiveWorkbook
    Set Sh1 = wb1.Sheets("Sheet1")
    Set Sh2 = wb1.Sheets("Sheet2")
    Dim srg As Range, srCount As Long
    
    With Sht1.Range(SRC_FIRST_CELL)
    srCount = .Worksheet.Cells( _
            .Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row + 1
           If srCount < 1 Then Exit Sub ' no data
        Set srg = .Resize(srCount)
End With
        
    Dim sCols() As String: sCols = Split(SRC_COLS_LIST, ",")
    Dim lCells() As String: lCells = Split(LKP_CELLS_LIST, ",")
        
    Dim rg As Range, Percentage, n As Long
    
    For n = 0 To UBound(sCols)
        Percentage = Sht2.Range(lCells(n)).Value
        If VarType(Percentage) = vbDouble Then
            If Percentage > 0 Then
                Set rg = srg.EntireRow.Columns(sCols(n))
                IncreaseRange rg, Percentage
            End If
        End If
    Next n

End Sub



Sub IncreaseRange( _
       ByVal rg As Range, _
       ByVal Percentage As Double)
    
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim cCount As Long: cCount = rg.Columns.Count
    
    Dim Data()
    
    If rCount * cCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
    Else
        Data = rg.Value
    End If
    
    Dim Factor As Double: Factor = 1 + Percentage
    
    Dim Value, r As Long, c As Long
    
    For r = 1 To rCount
        For c = 1 To cCount
            Value = Data(r, c)
            If VarType(Value) = vbDouble Then
                Data(r, c) = Data(r, c) * Factor
            End If
        Next c
    Next r

    rg.Value = Data

End Sub

Increase by Percentage

The Example

<!-- language: lang-vb -->

Sub IncreaseRangeTEST()
Const SRC_FIRST_CELL As String = "A2"
Const SRC_COLS_LIST As String = "B:C,D"
Const LKP_CELLS_LIST As String = "A2,A4"
Dim srg As Range, srCount As Long
With Sheet1.Range(SRC_FIRST_CELL)
srCount = .Worksheet.Cells( _
.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row + 1
If srCount < 1 Then Exit Sub ' no data
Set srg = .Resize(srCount)
End With
Dim sCols() As String: sCols = Split(SRC_COLS_LIST, ",")
Dim lCells() As String: lCells = Split(LKP_CELLS_LIST, ",")
Dim rg As Range, Percentage, n As Long
For n = 0 To UBound(sCols)
Percentage = Sheet2.Range(lCells(n)).Value
If VarType(Percentage) = vbDouble Then
If Percentage > 0 Then
Set rg = srg.EntireRow.Columns(sCols(n))
IncreaseRange rg, Percentage
End If
End If
Next n
End Sub

The Method

<!-- language: lang-vb -->

Sub IncreaseRange( _
ByVal rg As Range, _
ByVal Percentage As Double)
Dim rCount As Long: rCount = rg.Rows.Count
Dim cCount As Long: cCount = rg.Columns.Count
Dim Data()
If rCount * cCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
Dim Factor As Double: Factor = 1 + Percentage
Dim Value, r As Long, c As Long
For r = 1 To rCount
For c = 1 To cCount
Value = Data(r, c)
If VarType(Value) = vbDouble Then
Data(r, c) = Data(r, c) * Factor
End If
Next c
Next r
rg.Value = Data
End Sub

Toss this in your Sheet2 worksheet. It will trigger on the change of cells A2 & A4. If you need to use arrays instead of the range, in the select case we can change the range to an array & pass it to the IncreaseRange procedure and the for each loop to a multi-layered loop to scan a 2d array.

Option Explicit
Private Sub IncreaseRange(ByVal oMultiplier As Double, ByRef oTarget As Range)
Dim oValue As Variant
For Each oValue In oTarget
oValue.Value = oValue.Value * (1 + oMultiplier)
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Select Case Target.Address
Case "$A$2"
Call IncreaseRange(Target.Value, Sheet1.Range("B2:C" & LastRow))
Case "$A$4"
Call IncreaseRange(Target.Value, Sheet1.Range("D2:D" & LastRow))
End Select
End Sub