Snasui Excel Forum

Code: Select all

Sub UpdateData()
    Dim rs As Range, rsAll As Range
    Dim rt As Range, rtAll As Range
    Dim PctDone As Single
    Dim Row As Long
    Dim Col As Long
    Dim iCount As Long
    UserForm1.Show vbModeless
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        Set rsAll = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        Row = rsAll.Rows.Count
        Col = rsAll.Columns.Count
    End With
    With Sheets("Sheet2")
        Set rtAll = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rt In rtAll
        For Each rs In rsAll
            If rs = rt Then
                rs.EntireRow.Copy
                rt.EntireRow.PasteSpecial xlPasteValues
                iCount = iCount + 1
            End If
        Next rs
        PctDone = iCount / (Row * Col)
        Call UpdateProgress(PctDone)
    Next rt
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Unload UserForm1
End Sub