Excel VBA to calculate Euro in one column and USD in an adjacent column when currency value is placed in either column

[corey510]

I am pretty solid in my excel skills but am still learning about VBA. I am trying to figure out the script for performing an automated currency calulation (currency converter) when the cell in the first column is selected and a value is entered. The adjacent cell next to it should perform the currency calculation and return a value. Let me set the scene; $A$1 has my currency conversion Range B2:B2002 are the cells reserved to enter a value in dollars(one cell at a time). Range C2:2002 are the cells reserved to enter a value in Euros (one cell at a time). So basically if I enter a value in dollars, it calculates Euros and vise versa. But, I also want to be able to change and recalculate as needed in the same cells. So lets say I enter a value in dollars in any cell in the range B2:B2002 and it calculates euros in the adjacent cell in range C2:2002 (so now neither cell is blank). I want to be able to change the euro value in an already calculated cell (C2:2002) and perforn the calculation back to dollars in the corresponding cell in range B2:B2002. I only want to calculate all the cells at once, but rather one cell at a time.

A$1$ = 1.15
USD to EURO Formula = ROUND(B / $A$1,5)
EUOR to USD Formula = ROUND(C * $A$1,5)

 

[JackDanIce]

Welcome to the board.

In A1 I entered 1.18

B2:B4 has values 1, 2 and 3 respectively, C2:C4 are empty
C5:C7 has values 1, 2 and 3, B2:B7 are empty

Then ran following to fill in the empty cells as described (it adjusts for any number of rows in column B or C):

Sub Convert()

    Dim arr()   As Variant
    Dim x       As Long
    
    x = Application.Max(Cells(Rows.count, 2).End(xlUp).row, Cells(Rows.count, 3).End(xlUp).row)
    arr = Cells(1, 1).Resize(x, 3).Value
    
    For x = LBound(arr, 1) + 1 To UBound(arr, 1)
        If Len(arr(x, 2)) > 0 Then
            arr(x, 3) = arr(x, 2) / arr(1, 1)
        Else
            arr(x, 2) = arr(x, 3) * arr(1, 1)
        End If
    Next x
    
    With Cells(1, 1)
        .Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .Offset(, 1).Resize(, 2).NumberFormat = "#.0000"
    End With
    Erase arr

End Sub

 

[corey510]

Thanks Jack,
Your code does initially perform the conversion:

<colgroup><col style="width:48pt" width="64" span="3"> </colgroup><tbody>
[TD="width: 64, align: right"]1.18[/TD]
[TD="class: xl63, width: 64"][/TD]
[TD="class: xl63, width: 64"][/TD]

[TD="align: right"]1[/TD]
[TD="align: right"]0.847458[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"]1.694915[/TD]

[TD="align: right"]3[/TD]
[TD="align: right"]2.542373[/TD]

[TD="align: right"]1.18[/TD]
[TD="align: right"]1[/TD]

[TD="align: right"]2.36[/TD]
[TD="align: right"]2[/TD]

[TD="align: right"]3.54[/TD]
[TD="align: right"]3
[/TD]

</tbody>

But if I try to change column C cells, it does not automatically convert in column B. I attemped to change C2 to the number 5 and it made no change to B2. I want to be able to change data in either cell and have the adjacent cell compensate.

How do I get the code to run automatically and everytime I change a cell value?

<colgroup><col style="width:48pt" width="64" span="3"> </colgroup><tbody>
[TD="class: xl65, width: 64"][/TD]
[TD="class: xl65, width: 64"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

</tbody>

 

[JackDanIce]

Try with a worksheet change event:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim x   As Long
    
    With Target
        x = Cells(Rows.count, .column).End(xlUp).row
        If Not Intersect(Target, Cells(1, .column).Resize(x)) Is Nothing Then
            If .column = 2 Then
                .Value = .Offset(, 1) * Cells(1, 1).Value
            Else
                .Value = .Offset(, -1) / Cells(1, 1).Value
            End If
        End If
    End With
    
End Sub

 

[corey510]

Hey Jack,
I wasn't able to get that to run. What am I doing wrong?

 

[JackDanIce]

Did you insert the code into the correct worksheet object rather than a module?

This link explains worksheet change events

 

[corey510]

Yes, but no luck.

 

[JackDanIce]

I'm not sure. Made a slight edit, however, this does work for me when changes are made to columns B or C, with an exchange rate in A1:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim x   As Long
    
    With Target
        x = Cells(Rows.count, .column).End(xlUp).row
        If Not Intersect(Target, Cells(2, .column).Resize(x - 1)) Is Nothing Then
            If .column = 2 Then
                .Offset(, 1).Value = .Value * Cells(1, 1).Value
            Else
                .Offset(, -1) = .Value / Cells(1, 1).Value
            End If
        End If
    End With
    
End Sub

 

[corey510]

Hey Jack,

Thank you. It does work. I do require a little more functionality. If i change the intercept number (exchange rate in provided in A1) I need it to automatically recalculate B and C. It also seems to be rounding the calculated number to 4 decimal places. How do i get it to round to 5?