Gaining efficiency in VBA Loop, Minimise Traffic

[TrickyB89]

Hi,

Hoping for a way to speed up this loop. Currently this VBA transfers two values at a time (Latitude and Longitude) as inputs into a calculator on a separate worksheet which calculates the distance from the start of the road based on proximity to other points (number of different functions/look ups). The outputs generated from the "calculator sheet" (i.e road chainage, road name, offset from road centre line etc.) are then transferred back alongside the original coordinates.

I was thinking reading the Latitude and Longitude into VBA somehow to minimise traffic between VBA and worksheet.

Please see below extract:

Sub Chainage()


Dim Chain As Range
Dim Name As Range
Dim Offset As Range




  Application.ScreenUpdating = False
    'Start to loop
    For Each Cell In [A2.A5000]
        Lat = Cell.Offset(0, 0)
        Lon = Cell.Offset(0, 1)
                
        If Not IsEmpty(Lon) Then
        Range("ChainageCalculator!B7").Value = Lat
        Range("ChainageCalculator!C7").Value = Lon
                
        Set Chain = Sheets("ChainageCalculator").Cells(7, 4)
        Set Name = Sheets("ChainageCalculator").Cells(7, 7)
        Set Offset = Sheets("ChainageCalculator").Cells(7, 5)


        Cell.Offset(0, 3) = Chain
        Cell.Offset(0, 2) = Name
        Cell.Offset(0, 4) = Offset
        
        End If
  
    Next
        
   Application.ScreenUpdating = True
  
    End Sub

 

[StephenCrump]

Welcome to the Forum!

I was thinking reading the Latitude and Longitude into VBA somehow to minimise traffic between VBA and worksheet.

Yes, spot on. Try:

Sub Chainage()

    Dim LastRow As Long, i As Long
    Dim vResults As Variant
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    vResults = Range("A2:E" & LastRow).Value
    
    Application.ScreenUpdating = False
    
    With Worksheets("ChainageCalculator")
        For i = 1 To UBound(vResults)
            .Range("B7").Value = vResults(i, 1)   'Lat
            .Range("C7").Value = vResults(i, 2)   'Lon
            vResults(i, 3) = .Range("G7").Value  'Name
            vResults(i, 4) = .Range("D7").Value 'Chain
            vResults(i, 5) = .Range("E7").Value 'Offset
        Next i
    End With
    
    Range("A2:E2").Resize(UBound(vResults)).Value = vResults
        
    Application.ScreenUpdating = True

End Sub

 

[TrickyB89]

Thankyou!
Increased speed by approximately 3%.