Excel / VBA / Adding progress bar

O

Ocean22

New Member
Joined
Aug 3, 2017
Messages
5
Dear All,

The code below searches for duplicate in different sheets of my workbook. The issue is that it takes a little while for it to be done. How can i add a progress indicator in the status bar at the bottom.
Thank you & Kind regards.



Sub dup()
Dim cell As Range
Dim cella As Range
Dim rng As Range
Dim srng As Range
Dim rng2 As Range
Dim SheetName As Variant
<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; white-space: inherit;">Application.ScreenUpdating = False
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone

Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Set srng = Sheets("Screener").Range("A7:A2000")
Set rng = Sheets("Rejected").Range("A7:A2000")
Set rng2 = Sheets("Full Data").Range("A7:A2000")

For Each cell In rng
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 4
cella.Offset(, 1) = "Rejected"
End If
Next cella
Next cell

For Each cell In rng2
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 5.5
cella.Offset(, 1) = "Reported"
End If
Next cella
Next cell


Application.ScreenUpdating = True</code>End Sub
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
Welcome to the board.

Untested (it may error), however, try:
Code: 
Sub Dup()

    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    Dim dic     As Object
    
    Set dic = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    
    With Sheets("Screener")
        .Cells(7, 1).Resize(9).Interior.ColorIndex = xlNone
        .Cells(1, 2).EntireColumn.Insert shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
        LR = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(LR - 6, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = xlNone
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            If dic.exists(arr(x, 1)) Then dic(arr(x, 1)) = 4
        Next x
    End With
    
    With Sheets("Screener")
        For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    .Interior.ColorIndex = dic(.Value)
                    .Offset(, 1).Value = "Rejected"
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    With Sheets("Full Data")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = 5.5
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
    For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    .Interior.ColorIndex = dic(.Value)
                    .Offset(, 1).Value = "Reported"
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    Application.ScreenUpdating = False
    
    Set dic = Nothing
    
End Sub
 
Last edited:
Upvote 0
JackDanIce said:
Welcome to the board.

Untested (it may error), however, try:
Code: 
Sub Dup()

    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    Dim dic     As Object
    
    Set dic = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    
    With Sheets("Screener")
        .Cells(7, 1).Resize(9).Interior.ColorIndex = xlNone
        .Cells(1, 2).EntireColumn.Insert shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
        LR = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(LR - 6, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = xlNone
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            If dic.exists(arr(x, 1)) Then dic(arr(x, 1)) = 4
        Next x
    End With
    
    With Sheets("Screener")
        For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    .Interior.ColorIndex = dic(.Value)
                    .Offset(, 1).Value = "Rejected"
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    With Sheets("Full Data")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = 5.5
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
    For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    .Interior.ColorIndex = dic(.Value)
                    .Offset(, 1).Value = "Reported"
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    Application.ScreenUpdating = False
    
    Set dic = Nothing
    
End Sub
Click to expand...


Hi JackDanIce, greatly appreciate your help. Its working much smoother now ( no need for progress bar ) :) but one thing. I'm getting "Rejected" for each duplicate it finds no matter where its coming from. If possible i would like to identify in which sheet is it duplicated.


Cheers!
 
Upvote 0
Below i'm attaching a a graph of what i want to achieve.


HTML: 
<blockquote class="imgur-embed-pub" lang="en" data-id="a/hTOMe"><a href="//imgur.com/hTOMe"></a></blockquote>******** async src="//s.imgur.com/min/embed.js" charset="utf-8">*********>
 
Upvote 0
Glad it's smoother, slight edit, try:
Code: 
Sub Dup()


    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    Dim dic     As Object
    
    Set dic = CreateObject("Scripting.Dictionary")


    Application.ScreenUpdating = False
    
    With Sheets("Screener")
        .Cells(7, 1).Resize(9).Interior.ColorIndex = xlNone
        .Cells(1, 2).EntireColumn.Insert shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
        LR = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(LR - 6, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = xlNone
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            If dic.exists(arr(x, 1)) Then dic(arr(x, 1)) = 4
        Next x
    End With
    
    With Sheets("Screener")
        For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    .Interior.ColorIndex = dic(.Value)
                    .Offset(, 1).Value = "Rejected"
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    With Sheets("Full Data")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = 5.5
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
    For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    If Len(.Offset(, 1).Value) = 0 Then
                        .Interior.ColorIndex = dic(.Value)
                        .Offset(, 1).Value = "Reported"
                    End If
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    Application.ScreenUpdating = False
    
    Set dic = Nothing
    
End Sub
 
Upvote 0
url]
 
Upvote 0
Hi JackDanIce, Thanks again for such a quick reply. I tried the code but i'm still getting values that are located in the "Full Data" Sheet as Rejected and they should come up as reported. I have been playing around with to try an fix but no luck yet.
 
Upvote 0
Made a slight change but without your file, difficult to tell why it's doing what it's doing:
Code: 
Sub Dup()


    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    Dim dic     As Object
    
    Set dic = CreateObject("Scripting.Dictionary")


    Application.ScreenUpdating = False
    
    With Sheets("Screener")
        .Cells(7, 1).Resize(9).Interior.ColorIndex = xlNone
        .Cells(1, 2).EntireColumn.Insert shift:=xlToRight, copyorigin:=xlFormatFromLeftOrAbove
        LR = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(LR - 6, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = 4
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            If Not dic.exists(arr(x, 1)) Then dic(arr(x, 1)) = xlNone
        Next x
    End With
    
    With Sheets("Screener")
        For x = 7 To LR
            If dic.exists(.Cells(x, 1).Value) Then
                With .Cells(x, 1)
                    .Interior.ColorIndex = dic(.Value)
                    .Offset(, 1).Value = "Rejected"
                End With
            End If
        Next x
    End With
    dic.RemoveAll
    
    With Sheets("Full Data")
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        arr = .Cells(7, 1).Resize(x - 6).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = 5.5
        Next x
    End With
    Erase arr
    
    With Sheets("Rejected")
        For x = 7 To LR
            With .Cells(x, 1)
                If dic.exists(.Value) And Len(.Offset(, 1).Value) = 0 Then
                        .Interior.ColorIndex = dic(.Value)
                        .Offset(, 1).Value = "Reported"
                End If
            End With
        Next x
    End With
    dic.RemoveAll
    
    Application.ScreenUpdating = False
    
    Set dic = Nothing
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
ActiveCell vs Active range search
Replies
3
Views
438
Joe4
Joe4
E
  • Solved
Subroutine to Add Cell Comments Not Updating the Contents Correctly
Replies
7
Views
625
CephasOz
CephasOz
B
  • Question Question
Macro amends formulas in error on a different sheet?
Replies
1
Views
452
Alex Blakenburg
A
O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
635
OilEconomist
O
I
  • Question Question
Modify VBA script to count rows with data in multiple sheets
Replies
0
Views
403
irishjsk
I

Forum statistics

Threads
1,223,714
Messages
6,174,051
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top