Transfer Data Loop

Bah73 · Dec 15th 2021

Hi,

I have a Transfer Data loop that runs very slow.

Is there any way to make this more efficeint?

Code

Sub Transfer_Comments()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim Last As Long
    Dim i As Long
    Dim j As Long
    
    Set WS1 = Worksheets("Sheet 1")
    Set WS2 = Worksheets("Sheet 2")
  
'Transfer Comments
    For i = 1 To WS1.Cells(WS1.Rows.Count, 2).End(xlUp).Row
    For j = 1 To WS2.Cells(WS2.Rows.Count, 2).End(xlUp).Row
        If WS1.Cells(i, 11).Value2 = WS2.Cells(j, 11).Value2 And WS1.Cells(i, 14).Value2 = WS2.Cells(j, 14).Value2 Then
            WS1.Cells(i, 10).Value = WS2.Cells(j, 10).Value
            WS1.Cells(i, 22).Value = WS2.Cells(j, 22).Value
        End If
    Next j
    Next i

    WS2.Delete
    
    Set WS1 = Nothing
    Set WS2 = Nothing
  
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Display More

**KjBox** · Dec 15th 2021

Can any values in Sheet1 column A and column N have more than one match in Sheet 2 column A and column N?

Bah73 · Dec 15th 2021

No that combination creates a unique value.

**royUK** · Dec 15th 2021

Attach an example workbook

Bah73 · Dec 15th 2021

Ok will do tomorrow thanks.

**KjBox** · Dec 15th 2021

Try this

Code

Sub Transfer_Comments()
    Dim x, y, i As Long, ii As Long
    
    x = Sheets(1).Cells(1).CurrentRegion
    y = Sheets(2).Cells(1).CurrentRegion
    
    For i = 1 To UBound(x, 1)
        For ii = 1 To UBound(y, 1)
            If x(i, 11) = y(ii, 11) And x(i, 14) = y(ii, 14) Then
                x(i, 22) = y(ii, 22)
                Exit For
            End If
        Next
    Next
    Sheets(1).Cells(1).CurrentRegion = x
    Application.DisplayAlerts = 0
    Sheets(2).Delete
    Application.DisplayAlerts = 0

End Sub

Display More

Bah73 · Dec 16th 2021

Thanks KjBox that works awesome

Is there any way to name the sheets instead of sheets(1) and Sheets(2)?

ie

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Worksheets("Base")
Set WS2 = Worksheets("Comments")

**KjBox** · Dec 17th 2021

Like this

Code

Sub Transfer_Comments()
 Dim x, y, i As Long, ii As Long
 
 x = Sheets("Base").Cells(1).CurrentRegion
 y = Sheets("Comment").Cells(1).CurrentRegion
 
 For i = 1 To UBound(x, 1)
 For ii = 1 To UBound(y, 1)
 If x(i, 11) = y(ii, 11) And x(i, 14) = y(ii, 14) Then
 x(i, 22) = y(ii, 22)
 Exit For
 End If
 Next
 Next
 Sheets("Base").Cells(1).CurrentRegion = x
 Application.DisplayAlerts = 0
 Sheets("Comment").Delete
 Application.DisplayAlerts = 0
End Sub

Display More

Transfer Data Loop

Participate now!

Share