locked
Is there a way to speed Macro up? RRS feed

  • Question

  • Sub Match()
    Application.ScreenUpdating = False
         Dim w1 As Worksheet
         Dim w2 As Worksheet
         Dim rng As Range
         Dim m As Long
         Dim r As Long
         Dim s As Long    
                  Set w1 = Worksheets("Sheet1")
                        Set w2 = Worksheets("Sheet2")    
                             m = w2.Cells(w2.Rows.Count, 2).End(xlUp).Row
                         For r = 2 To m
                  Set rng = w1.Columns(2).Find(What:=w2.Cells(r, 2).Value, LookAt:=xlWhole)
                  If Not rng Is Nothing Then
                        s = rng.Row
                            w2.Cells(r, 3).Value = w1.Cells(s, 3).Value
                       w2.Cells(r, 4).Value = w1.Cells(s, 4).Value            
                  End If
        Next r
     Application.CutCopyMode = False
     Worksheets("Sheet2").Cells.EntireColumn.AutoFit
     Worksheets("Sheet2").Cells.EntireColumn.HorizontalAlignment = xlLeft
     Application.ScreenUpdating = True  
    End Sub
    Tuesday, May 5, 2020 9:11 PM

Answers

  • How about this?

    Sub Match()
        Dim w1 As Worksheet
        Dim w2 As Worksheet
        Dim m As Long
        Dim n As Long
        Application.ScreenUpdating = False
        Set w1 = Worksheets("Sheet1")
        n = w1.Cells(w1.Rows.Count, 2).End(xlUp).Row
        Set w2 = Worksheets("Sheet2")
        m = w2.Cells(w2.Rows.Count, 2).End(xlUp).Row
        With w2.Range("C2:C" & m)
            .Formula = "=IFERROR(VLOOKUP(B2,Sheet1!$B$2:$D$" & n & ",2,FALSE),"""")"
            .Value = .Value
        End With
        With w2.Range("D2:D" & m)
            .Formula = "=IFERROR(VLOOKUP(B2,Sheet1!$B$2:$D$" & n & ",3,FALSE),"""")"
            .Value = .Value
        End With
        Worksheets("Sheet2").Cells.EntireColumn.AutoFit
        Worksheets("Sheet2").Cells.EntireColumn.HorizontalAlignment = xlLeft
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    • Marked as answer by VBShaper Tuesday, May 5, 2020 10:22 PM
    Tuesday, May 5, 2020 9:41 PM

All replies

  • How about this?

    Sub Match()
        Dim w1 As Worksheet
        Dim w2 As Worksheet
        Dim m As Long
        Dim n As Long
        Application.ScreenUpdating = False
        Set w1 = Worksheets("Sheet1")
        n = w1.Cells(w1.Rows.Count, 2).End(xlUp).Row
        Set w2 = Worksheets("Sheet2")
        m = w2.Cells(w2.Rows.Count, 2).End(xlUp).Row
        With w2.Range("C2:C" & m)
            .Formula = "=IFERROR(VLOOKUP(B2,Sheet1!$B$2:$D$" & n & ",2,FALSE),"""")"
            .Value = .Value
        End With
        With w2.Range("D2:D" & m)
            .Formula = "=IFERROR(VLOOKUP(B2,Sheet1!$B$2:$D$" & n & ",3,FALSE),"""")"
            .Value = .Value
        End With
        Worksheets("Sheet2").Cells.EntireColumn.AutoFit
        Worksheets("Sheet2").Cells.EntireColumn.HorizontalAlignment = xlLeft
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    • Marked as answer by VBShaper Tuesday, May 5, 2020 10:22 PM
    Tuesday, May 5, 2020 9:41 PM
  • How about this?

    Sub Match()
        Dim w1 As Worksheet
        Dim w2 As Worksheet
        Dim m As Long
        Dim n As Long
        Application.ScreenUpdating = False
        Set w1 = Worksheets("Sheet1")
        n = w1.Cells(w1.Rows.Count, 2).End(xlUp).Row
        Set w2 = Worksheets("Sheet2")
        m = w2.Cells(w2.Rows.Count, 2).End(xlUp).Row
        With w2.Range("C2:C" & m)
            .Formula = "=IFERROR(VLOOKUP(B2,Sheet1!$B$2:$D$" & n & ",2,FALSE),"""")"
            .Value = .Value
        End With
        With w2.Range("D2:D" & m)
            .Formula = "=IFERROR(VLOOKUP(B2,Sheet1!$B$2:$D$" & n & ",3,FALSE),"""")"
            .Value = .Value
        End With
        Worksheets("Sheet2").Cells.EntireColumn.AutoFit
        Worksheets("Sheet2").Cells.EntireColumn.HorizontalAlignment = xlLeft
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (https://www.eileenslounge.com)

    Works perfectly. Thank you!
    Tuesday, May 5, 2020 10:23 PM