Why looping through a range breaks my code?

Question

I have an Excel file where I'm trying to convert prices in different currencies. I've made a macro which determines the currency and convert it into a cell in the R column. I would like to loop this through the R column until there is nothing in the currency cell.

I made a macro, but when I'm trying to loop it freezes Excel. I would be really grateful for your help, the code is the following:

Sub valutakereses()
    Dim c As Range
    Dim price As Range

    With ActiveSheet.Range("A1:Z1")
        Set c = .Find("Cost currency", LookAt:=xlWhole)
        Set price = .Find("INTL Price", LookAt:=xlWhole)
    End With
    
    ActiveSheet.Range("R2").Select
    Do
        Set c = c.Offset(1, 0)
        Set price = price.Offset(1, 0)
        If c = "US$" Then
            ActiveCell.FormulaR1C1 = price * "300"
        ElseIf c = "DKK" Then
            ActiveCell.FormulaR1C1 = price * "50"
        ElseIf c = "EUR" Then
            ActiveCell.FormulaR1C1 = price * "365"
        ElseIf c = "GBP" Then
            ActiveCell.FormulaR1C1 = price * "405"
        ElseIf c = "NKR" Then
            ActiveCell.FormulaR1C1 = price * "35"
        ElseIf c = "SEK" Then
            ActiveCell.FormulaR1C1 = price * "36"
        ElseIf c = "SGD" Then
            ActiveCell.FormulaR1C1 = price * "225"
        ElseIf c = "SKR" Then
            ActiveCell.FormulaR1C1 = price * "36"
        End If
        ActiveCell.Offset(1, 0).Select
    Loop While Not c Is Nothing
End Sub

Answer 1

Please read the comments and adjust the code to fit your needs

Public Sub valutakereses()
    
    ' Define the target sheet
    Dim targetSheet As Worksheet
    Set targetSheet = ActiveSheet ' Change ActiveSheet to: ThisWorkbook.Worksheets("SheetName")
    
    ' Define the headers location
    Dim headerRange As Range
    Set headerRange = targetSheet.Range("A1:Z1")
    
    ' Find the currency header cell
    Dim currencyHeader As Range
    Set currencyHeader = headerRange.Find("Cost currency", LookAt:=xlWhole)

    ' Find the price header cell
    Dim priceHeader As Range
    Set priceHeader = headerRange.Find("INTL Price", LookAt:=xlWhole)
    
    ' Find the result header cell
    Dim resultHeader As Range
    Set resultHeader = headerRange.Find("SOME TITLE", LookAt:=xlWhole)
    
    ' Find the last row in currency column
    Dim lastRow As Long
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, currencyHeader.Column).End(xlUp).Row
    
    ' Find the currency range (from header to last row)
    Dim currencyRange As Range
    Set currencyRange = targetSheet.Range(currencyHeader.Offset(1, 0), currencyHeader.Offset(lastRow - currencyHeader.Row))
    
    ' Loop through cells in column
    Dim currencyCell As Range
    For Each currencyCell In currencyRange
        
        ' Select the price value
        Dim priceValue As Long
        Select Case currencyCell.Value
        Case "US$"
            priceValue = 300
        Case "DKK"
            priceValue = 50
        Case "EUR"
            priceValue = 365
        Case "GBP"
            priceValue = 405
        Case "NKR"
            priceValue = 35
        Case "SEK"
            priceValue = 36
        Case "SGD"
            priceValue = 225
        Case "SKR"
            priceValue = 36
        Case Else
            ' Adjust this last case
            priceValue = 0
        End Select
        
        ' Multiply price
        targetSheet.Cells(currencyCell.Row, resultHeader.Column).Value = targetSheet.Cells(currencyCell.Row, priceHeader.Column).Value * priceValue
        
    Next currencyCell
    
End Sub

Note: Proper error handling should be added

Let me know if it works

Answer 2

Using Application.Match

• You should consider applying the same principle as I did for the Currency Column (cHeader (cCol)) and Price Column (pHeader (pCol)), for the Result Column (rHeader (rCol)).

The Code

Option Explicit

Sub valutakereses()
    
    Const wsName As String = "Sheet1" ' Worksheet Name
    Const hRow As Long = 1 ' Header Row
    Const rCol As String = "R" ' Result Column
    Const cHeader As String = "Cost currency" ' Currency Header
    Const pHeader As String = "INTL Price" ' Price Header
    Const CurrenciesList As String = "US$,DKK,EUR,GBP,NKR,SEK,SGD,SKR"
    Dim Currencies() As String: Currencies = Split(CurrenciesList, ",")
    Dim Prices As Variant
    Prices = VBA.Array(300, 50, 365, 405, 35, 36, 225, 26)
    
    ' In the worksheet "Sheet1" of the workbook containing this code...
    With ThisWorkbook.Worksheets(wsName)
        ' Calculate Currency and Price Column Numbers.
        With .Rows(hRow)
            Dim cCol As Long: cCol = Application.Match(cHeader, .Cells, 0)
            Dim pCol As Long: pCol = Application.Match(pHeader, .Cells, 0)
        End With
        ' Calculate the Last Row, the row of the last non-empty Cell
        ' in Currency Column.
        Dim LRow As Long: LRow = .Cells(.Rows.Count, cCol).End(xlUp).Row
        ' Declare additional variables (to be used in the 'For Next' loop).
        Dim cMatch As Variant ' Current Match
        Dim i As Long ' Worksheet Rows Counter
        ' Loop through rows of the worksheet...
        For i = hRow + 1 To LRow
            ' Try to find the value in Currency Column, in Currencies Array.
            cMatch = Application.Match(.Cells(i, cCol).Value, Currencies, 0)
            ' If found...
            If IsNumeric(cMatch) Then
                ' Multiply the value from Price Column by the 'matching' value
                ' in Prices Array and write the result to the Result Column.
                .Cells(i, rCol).Value = .Cells(i, pCol).Value _
                    * Prices(cMatch - 1)
            End If
        Next i
    End With

End Sub