Оптимизация кода при помощи цикла - VBA

Формулировка задачи:

Здравствуйте дорогие прогеры есть файл (приложил), в лист 1 справа необходимо проставить курсы из листа курсы за каждый день написал тупой код, можно его как то циклом или как нибудь оптимизировать? буду рад за любую помощь

                    Листинг программы
                
 
                            
                        
Dim usd As String
usd = "USD"
 
Dim euro As String
euro = "EUR"
 
Dim kol As Integer
kol = 3000
 
For i = 1 To kol
 
Dim val
 
Data = Sheets("Отчет (лист 1)").Cells(i, 9).Value
val = Sheets("Отчет (лист 1)").Cells(i, 10).Value
 
If Data = "01.07.2016" Then
    If val = usd Then
        Sheets("Отчет (лист 1)").Cells(i, 18) = Sheets("курсы").Cells(2, 2).Value
    End If
    
    If val = euro Then
        Sheets("Отчет (лист 1)").Cells(i, 18) = Sheets("курсы").Cells(2, 3).Value
    End If
End If
 
If Data = "02.07.2016" Then
    If val = usd Then
        Sheets("Отчет (лист 1)").Cells(i, 18) = Sheets("курсы").Cells(3, 2).Value
    End If
    
    If val = euro Then
        Sheets("Отчет (лист 1)").Cells(i, 18) = Sheets("курсы").Cells(3, 3).Value
    End If
End If
 
If Data = "03.07.2016" Then
    If val = usd Then
        Sheets("Отчет (лист 1)").Cells(i, 18) = Sheets("курсы").Cells(4, 2).Value
    End If
    
    If val = euro Then
        Sheets("Отчет (лист 1)").Cells(i, 18) = Sheets("курсы").Cells(4, 3).Value
    End If
End If

Решение задачи: «Оптимизация кода при помощи цикла»

textual
                            Листинг программы 
                        
 
                        
                          
                    
Sub Проставить_курсы_многих_валют()
    Dim i&, j&, A, B, Dic
    A = Worksheets("Курсы").[A1].CurrentRegion.Value
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    For i = 2 To UBound(A)
        For j = 2 To UBound(A, 2)
            Dic(A(i, 1) & A(1, j)) = A(i, j)
        Next j
    Next i
    With Worksheets(2)
        '.Range("R4:R" & .UsedRange.Rows.Count).ClearContents  'раскомментировать, если надо стереть все старые курсы
        B = Intersect(.UsedRange, .Columns("I:J")).Value
        For i = 4 To UBound(B)
            If Dic.Exists(B(i, 1) & B(i, 2)) Then .Cells(i, 18) = Dic(B(i, 1) & B(i, 2))
        Next i
    End With
    Set Dic = Nothing
End Sub