How to place and define progress bar with percentage

Hi,

Can anyone help me to create VBA code for percentage of completion as above to my VBA code below.

Sub SeachName_ArraySet()
Dim lngRet As Long, lngCount As Long, lngVar As Long
Dim var As Variant, varSheets As Variant, varBooks As Variant
Dim a1 As Integer, a2 As Integer, bk As Integer
Dim wb As Workbook, ws As Worksheet


var = Array("Azizah Yusoff", "Hoo Zhe Yee", "Ong Xie Jun", "Gregory Gan Chong Hee", "Ong Pui Sin")
varSheets = Array("Azizah", "Zhe Yee", "Xie Jun", "Gregory Gan", "Ong Pui")
varBooks = Array("BUSINESS BANKING.xlsx", "Auto Finance.xlsx", "Small Medium Enterprise.xlsx")


    For bk = LBound(varBooks) To UBound(varBooks)
    
        Set wb = Workbooks(varBooks(bk))
        
        For lngVar = LBound(var) To UBound(var)
                For Each ws In wb.Worksheets
                    If ws.Name = CStr(varSheets(lngVar)) Then GoTo Matchup
                Next: GoTo GetNext
                
Matchup:
lngRet = MatchName(ThisWorkbook.Name, "SOP BUSINESS UNIT - ORIGINATOR", CStr(var(lngVar)), 6)
      
                If lngRet <> 0 Then
                      For lngCount = 0 To 11

                         
                          'Pasting Code No.1
                          ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 3 + lngCount).Value = _
                              wb.Worksheets(CStr(varSheets(lngVar))).Range("H601").Offset(0, lngCount * 3).Value

                          'Pasting Code No.2
                          '
                          '
                          '
                          'Pasting Code No.9
                      Next lngCount
                      
                          'Pasting Code No.10
                          
                          ''''''''''''''''''update the progress bar for percentage of completion here'''''''''''''''''''''
                End If
          
GetNext:     Next lngVar
    
        Set wb = Nothing
    Next bk
End Sub

Hi sixthsense,

This code will make my VBA code running slowly, to many cells it runs (5000).

What I want is percentage bar will be updated after completing one row, i.e. cells(13,9) until cells(13,501)

If the cells move to the next row, cells(14,9), percentage bar will be automatically updated. max row is determined by Cells(Rows.Count, "F").End(xlUp).Row

e.g.
a = Cells(Rows.Count, "F").End(xlUp).Row

Thus range of rows is Range("F13" & a).select


Regards,
Farid

Hi Sixthsense,

Thanks for spend your time to assist me.

Hi sixthsense,

Your VBA code look better than before (nice Code), but still running out of limit, more than 100%.

I only change the sheet name and the rest remained the same.

Worksheets("Sheet1").Cells(lRow, iCol).Value = lRow


I attached the sample of small range workbooks consist of 5 persons . In fact, I have 200 persons to be updated. The estimated time is around 8-10 mins depending of Desktop processor.

The VBA code is in Consolidation SOP workbooks.

Thanks for your effort, I'm really appreciate

Hi sixthsense,

I have tried on this, but it runs out of limit & paste value to the cells. it should only count the completed cells.

Hi sixthsense,

when I press Esc button to cancel, Debug error stop at lCounter = lCounter + 1

Hi sixthsense,

The Esc button press when it runs out of limit (>100%).

and your progress bar code should not paste value to the cells. It should only count the cells.

I'm not 100% sure but looking at your code here:

Sub SeachName_ArraySet_A()
Dim lngRet As Long, lngCount As Long, lngVar As Long
Dim var As Variant, varSheets As Variant, varBooks As Variant
Dim a1 As Integer, a2 As Integer, bk As Integer
Dim wb As Workbook, ws As Worksheet

var = Array("Azizah Yusoff", "Hoo Zhe Yee", "Ong Xie Jun", "Gregory Gan Chong Hee", "Ong Pui Sin")
varSheets = Array("Azizah", "Zhe Yee", "Xie Jun", "Gregory Gan", "Ong Pui")
varBooks = Array("BUSINESS BANKING.xlsx", "Auto Finance.xlsx", "Small Medium Enterprise.xlsx")

    For bk = LBound(varBooks) To UBound(varBooks)
    
        Set wb = Workbooks(varBooks(bk))
    
            For lngVar = LBound(var) To UBound(var)
                For Each ws In wb.Worksheets
                If ws.Name = CStr(varSheets(lngVar)) Then GoTo Matchup
                Next: GoTo GetNext
Matchup:
lngRet = MatchName(ThisWorkbook.Name, "SOP BUSINESS UNIT - ORIGINATOR", CStr(var(lngVar)), 6)
          
          
          If lngRet <> 0 Then
                    For lngCount = 0 To 11
                    
                    'No.1
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 3 + lngCount).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("H601").Offset(0, lngCount * 3).Value
                    
                    'No.2
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 15 + lngCount * 3).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("H606").Offset(0, lngCount * 3).Value
                    'No.3
                    'No.4
                    'No.5
                    'No.6
                    'No.7
                    'No.8
                    'No.9
            
                    Next lngCount
                
                    'No.10
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 494).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("P612").Value
            
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 495).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("P614").Value

                    
                    '''''''''''''''''''''''''''''Maybe the percentage of progress bar update here''''''''''''''''''''''''''''''''
                    
                            Dim PercentComplete As Single, SubPercent As Single
                            Dim MaxRow As Long, lRow As Long, lTot As Long
                            Dim lCounter As Long, lIncre As Long, lSubTot As Long
                            Dim MaxCol As Integer, iCol As Integer
                            Dim StartCol As Integer, StartRow As Long
                            
                            MaxRow = Cells(Rows.Count, "F").End(xlUp).Row
                            MaxCol = 501
                            StartRow = 13: StartCol = 9
                            lTot = Range(Cells(StartRow, StartCol), Cells(MaxRow, MaxCol)).Rows.Count
                            lSubTot = MaxCol - StartCol
                            For lRow = StartRow To MaxRow
                                For iCol = StartCol To MaxCol
                                    Worksheets("SOP BUSINESS UNIT - ORIGINATOR").Cells(lRow, iCol).Value = lRow
                                    lIncre = lIncre + 1
                                    SubPercent = lIncre / lSubTot
                                    Application.StatusBar = Format(PercentComplete, "0%") & " Completed " & Format(SubPercent, "(0%)") & " In Progress"
                                Next
                                lCounter = lCounter + 1
                                PercentComplete = lCounter / lTot
                                Application.StatusBar = Format(PercentComplete, "0%") & " Completed"
                                DoEvents
                                lIncre = 0
                            Next
                            
                            Application.StatusBar = ""

                End If
            
GetNext:   Next lngVar
    
        Set wb = Nothing
    Next bk
End Sub

I think the problem could be that you are looping through the "progress bar" bit several times as part of the For lngVar = LBound(var) To UBound(var) but I don't think you reset the lCounter that you base your progress bar on, so for the 2nd, 3rd, 4th times etc, it will be going from whatever the previous lCounter value was. So maybe try adding, Lcounter = 0 before the for lrow = startrow to maxrow bit, e.g.:

Sub SeachName_ArraySet_A()
Dim lngRet As Long, lngCount As Long, lngVar As Long
Dim var As Variant, varSheets As Variant, varBooks As Variant
Dim a1 As Integer, a2 As Integer, bk As Integer
Dim wb As Workbook, ws As Worksheet

var = Array("Azizah Yusoff", "Hoo Zhe Yee", "Ong Xie Jun", "Gregory Gan Chong Hee", "Ong Pui Sin")
varSheets = Array("Azizah", "Zhe Yee", "Xie Jun", "Gregory Gan", "Ong Pui")
varBooks = Array("BUSINESS BANKING.xlsx", "Auto Finance.xlsx", "Small Medium Enterprise.xlsx")

    For bk = LBound(varBooks) To UBound(varBooks)
    
        Set wb = Workbooks(varBooks(bk))
    
            For lngVar = LBound(var) To UBound(var)
                For Each ws In wb.Worksheets
                If ws.Name = CStr(varSheets(lngVar)) Then GoTo Matchup
                Next: GoTo GetNext
Matchup:
lngRet = MatchName(ThisWorkbook.Name, "SOP BUSINESS UNIT - ORIGINATOR", CStr(var(lngVar)), 6)
          
          
          If lngRet <> 0 Then
                    For lngCount = 0 To 11
                    
                    'No.1
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 3 + lngCount).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("H601").Offset(0, lngCount * 3).Value
                    
                    'No.2
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 15 + lngCount * 3).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("H606").Offset(0, lngCount * 3).Value
                    'No.3
                    'No.4
                    'No.5
                    'No.6
                    'No.7
                    'No.8
                    'No.9
            
                    Next lngCount
                
                    'No.10
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 494).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("P612").Value
            
                        ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 495).Value = _
                            wb.Worksheets(CStr(varSheets(lngVar))).Range("P614").Value

                    
                    '''''''''''''''''''''''''''''Maybe the percentage of progress bar update here''''''''''''''''''''''''''''''''
                    
                            Dim PercentComplete As Single, SubPercent As Single
                            Dim MaxRow As Long, lRow As Long, lTot As Long
                            Dim lCounter As Long, lIncre As Long, lSubTot As Long
                            Dim MaxCol As Integer, iCol As Integer
                            Dim StartCol As Integer, StartRow As Long
                            lCounter = 0
                            MaxRow = Cells(Rows.Count, "F").End(xlUp).Row
                            MaxCol = 501
                            StartRow = 13: StartCol = 9
                            lTot = Range(Cells(StartRow, StartCol), Cells(MaxRow, MaxCol)).Rows.Count
                            lSubTot = MaxCol - StartCol
                            For lRow = StartRow To MaxRow
                                For iCol = StartCol To MaxCol
                                    Worksheets("SOP BUSINESS UNIT - ORIGINATOR").Cells(lRow, iCol).Value = lRow
                                    lIncre = lIncre + 1
                                    SubPercent = lIncre / lSubTot
                                    Application.StatusBar = Format(PercentComplete, "0%") & " Completed " & Format(SubPercent, "(0%)") & " In Progress"
                                Next
                                lCounter = lCounter + 1
                                PercentComplete = lCounter / lTot
                                Application.StatusBar = Format(PercentComplete, "0%") & " Completed"
                                DoEvents
                                lIncre = 0
                            Next
                            
                            Application.StatusBar = ""

                End If
            
GetNext:   Next lngVar
    
        Set wb = Nothing
    Next bk
End Sub

Ok, I see, try:

Sub SeachName_ArraySet_A()
Dim lngRet As Long, lngCount As Long, lngVar As Long
Dim var As Variant, varSheets As Variant, varBooks As Variant
Dim a1 As Integer, a2 As Integer, bk As Integer
Dim wb As Workbook, ws As Worksheet
var = Array("Azizah Yusoff", "Hoo Zhe Yee", "Ong Xie Jun", "Gregory Gan Chong Hee", "Ong Pui Sin")
varSheets = Array("Azizah", "Zhe Yee", "Xie Jun", "Gregory Gan", "Ong Pui")
varBooks = Array("BUSINESS BANKING.xlsx", "Auto Finance.xlsx", "Small Medium Enterprise.xlsx")
For bk = LBound(varBooks) To UBound(varBooks)
    Set wb = Workbooks(varBooks(bk))
    For lngVar = LBound(var) To UBound(var)
        Set ws = Nothing
        On Error Resume Next
        Set ws = wb.Sheets(varSheets(lngVar))
        On Error GoTo 0
        If Not ws Is Nothing Then
            lngRet = MatchName(ThisWorkbook.Name, "SOP BUSINESS UNIT - ORIGINATOR", CStr(var(lngVar)), 6)
            If lngRet <> 0 Then
                For lngCount = 0 To 11
                    ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 3 + lngCount).Value = _
                        wb.Worksheets(CStr(varSheets(lngVar))).Range("H601").Offset(0, lngCount * 3).Value
                    ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 15 + lngCount * 3).Value = _
                        wb.Worksheets(CStr(varSheets(lngVar))).Range("H606").Offset(0, lngCount * 3).Value
                Next lngCount
                ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 494).Value = _
                    wb.Worksheets(CStr(varSheets(lngVar))).Range("P612").Value
                ThisWorkbook.Sheets("SOP BUSINESS UNIT - ORIGINATOR").Range("F" & lngRet).Offset(0, 495).Value = _
                    wb.Worksheets(CStr(varSheets(lngVar))).Range("P614").Value
            End If
        End If
        Application.StatusBar = Format((bk * (UBound(var) + 1) + lngVar + 1) / ((UBound(varBooks) + 1) * (UBound(var) + 1)), "0%")
    Next lngVar
    Set wb = Nothing
Next bk
Application.StatusBar = False
End Sub

Hi ragulduy,

Unbelievable, it works . Thousands appreciation to you. , I have added reputation to you.


But the percentage jump from 18% to 49% and 55% to 89% . I guess, it could be due to one of the files completed pasting value.

I think that the percentage should go up in equal steps, but it will appear to skip some because if it doesn't find the worksheet it will move to the next counter and so will update quicker than you will be able to see. So the progress bar is based on the counter, not the number of sheets to open.

Hi ragulduy,

Thanks for the information.

However, i think excel can only give estimation % but cannot give accurate %.

To make it easy to check, I have created simple code and run a single step using F8 button.

Sub copyPaste()
Dim i As Long
Dim PercentComplete As Variant

Range("A1").Copy
        
    For i = 1 To 5000
    Cells(1, 3).Offset(i, 0).Select
    ActiveSheet.Paste
    PercentComplete = i / 5000
    Application.StatusBar = Format(PercentComplete, "0%") & " Completed"
    Next i

Application.CutCopyMode = False
End Sub

Excel display:
1% at row 25, should be at row 50
2% at row 76, should be at row 100
3% at row 128, should be at row 150

That's because you are rounding it to the nearest percent.

so row 128 = 128/5000 = 2.56% which is rounded to 3%.

Either change format(percentcomplete,"0%") to format(percentcomplete,"0.0%") or if you only want it to display 3% once 3% has been reached rather than rounding up then:
percentcomplete = worksheetfunction.rounddown(i/5000,2)

Hi ragulduy,

Thanks a lot. I have gained my knowledge.

Just to get confirmation, Is it possible to display time left?

If yes, I will ask in a new thread.

I suppose you could come up with a very rough estimate but it would be pretty much redundant.

I would suggest time a bunch of them and see how long they take, calculate the average of these times, divide this average by 100 to get the time for each percent and then use this to calculate how long is left (i.e. time taken per percent * number of percent remaining)

Hi ragulduy,

Here is the link for a new thread. To make it easy to understand, I only use simple code same as post #24.

I just want to get a basic learning, and clearly understand before go to complicated script.


http://www.excelforum.com/excel-prog...ml#post3712532