Consulting

Results 1 to 4 of 4

Thread: Progress bar...%

  1. #1
    VBAX Regular
    Joined
    Apr 2019
    Posts
    17
    Location

    Progress bar...%

    Hi,I want to add a progress bar which already designed in attached excel workbook with the name of Userform1. The progress bar should show the % of macro progress.Regards,Uday
    Attached Files Attached Files

  2. #2
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    544
    Location
    Hello Shamim,

    Here is the code to update the progress bar (UserForm1). The attached workbook has the code shown added to it.

    Option Explicit
    
    
    Public Completed    As Long
    Public EndCount     As Long
     
    Sub Split_Data_in_workbooks()
    
    
    Application.ScreenUpdating = False
    
    
    
    
    Dim data_sh As Worksheet
    Set data_sh = ThisWorkbook.Sheets("Data")
    
    
    Dim setting_Sh As Worksheet
    Set setting_Sh = ThisWorkbook.Sheets("Settings")
    
    
    Dim nwb As Workbook
    Dim nsh As Worksheet
    
    
    Dim wkbPath As String
    
    
    ''''' Get unique supervisors
    
    
    setting_Sh.Range("A:A").Clear
    data_sh.AutoFilterMode = False
    data_sh.Range("B:B").Copy setting_Sh.Range("A1")
    
    
    setting_Sh.Range("A:A").RemoveDuplicates 1, xlYes
    
    
    Dim i As Integer
    
    
    Completed = 0
    
    
    UserForm1.Show False
    
    
    EndCount = Application.CountA(setting_Sh.Range("A:A"))
    
    
    wkbPath = setting_Sh.Range("H6")
    If wkbPath = "" Then wkbPath = ThisWorkbook.Path
    
    
    For i = 2 To EndCount
        
        DoEvents
        
        Completed = Completed + 1
        With UserForm1
            .Label2.Width = .Label1.Width * (Completed / (EndCount - 1))
            .Label3.Caption = "Percent complete " & Format(Completed / (EndCount - 1), "0%")
        End With
        
        data_sh.UsedRange.AutoFilter 2, setting_Sh.Range("A" & i).Value
        
        Set nwb = Workbooks.Add
        Set nsh = nwb.Sheets(1)
        
        data_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
        nsh.UsedRange.EntireColumn.ColumnWidth = 15
        
        nwb.SaveAs wkbPath & "/" & setting_Sh.Range("A" & i).Value & ".xlsx"
        nwb.Close False
        data_sh.AutoFilterMode = False
    Next i
    
    
    setting_Sh.Range("A:A").Clear
    
    
    End Sub
    Attached Files Attached Files
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  3. #3
    VBAX Regular
    Joined
    Apr 2019
    Posts
    17
    Location
    Thanks!!

  4. #4
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    544
    Location
    Hello Shamim,

    You're welcome.
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •