Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Некорректный расчет процента выполнения - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Некорректный расчет процента выполнения (Макросы/Sub)
Некорректный расчет процента выполнения
Andruha149 Дата: Вторник, 25.07.2017, 13:46 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Всем привет. Я не эксперт vba, поэтому сразу сори, если у кого-то мой код вызовет судороги)) он слеплен из нескольких. Имеется:

Код полоски выполнения процентов:

[vba]
Код
Option Explicit
Public bShowBar As Boolean
Public dblProgressWidth As Double, dblStep As Double, dblPercent As Double
Sub MyProgresBar()
    dblProgressWidth = dblProgressWidth + dblStep
    frmStatusBar.FrameProgress.Width = dblProgressWidth
    If dblProgressWidth > dblPercent Then
        frmStatusBar.lblPercentWhite.Caption = Format(dblPercent / frmStatusBar.FramePrgBar.Width, "0%")
        frmStatusBar.lblPercentBlack.Caption = frmStatusBar.lblPercentWhite.Caption
        dblPercent = dblPercent + dblStep
        frmStatusBar.Repaint
        DoEvents
    End If
End Sub
Function Show_PrBar_Or_No(lCnt As Long, Optional sUfCaption As String = "Initializing")
    bShowBar = (lCnt > 10)
    If bShowBar = False Then Exit Function
    
    frmStatusBar.Caption = sUfCaption
    dblStep = frmStatusBar.FramePrgBar.Width / lCnt
    frmStatusBar.lblPercentWhite.Left = 96
    frmStatusBar.lblPercentBlack.Left = frmStatusBar.lblPercentWhite.Left
    
    frmStatusBar.Show 0
    dblPercent = 0: dblProgressWidth = 0
End Function
[/vba]

Код кнопки на открытие файлов в папке и копирования данных через добавление строки.

[vba]
Код
Sub Button1_Click()

    Dim c As Long
    [f1] = 0
    If Dir("C:\Users\andruha149\Desktop\Reports\My project\pmf macros\*.*") = "" Then Exit Sub Else c = 1
    Do
      If Dir = "" Then Exit Do Else c = c + 1
    Loop Until False
    [f1] = c
    

    Dim lr As Long
    Dim lAllCnt As Long
    lAllCnt = [f1]
    Call Show_PrBar_Or_No(lAllCnt, "Initializing...")
        
    Dim sFolder As String
    Dim sFile As String
    Dim wbD As Workbook, wbS As Workbook
     
    Application.ScreenUpdating = False
    Set wbS = thisWorkbook
    sFolder = wbS.Path & "\"
     
    sFile = Dir(sFolder)
   
    Do While sFile <> ""
        
        For lr = 0 To lAllCnt
        If bShowBar Then Call MyProgresBar
            Next
         
        If sFile <> wbS.Name Then
            Set wbD = Workbooks.Open(sFolder & sFile) 'open the file; add condition to
            wbD.Sheets("PMF").Range("A2:NS2").Copy
            wbS.Activate
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[1],RC[2]&""-""&RC[3])"
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormats
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            wbD.Close savechanges:=True 'close without saving
        End If

         
        sFile = Dir 'next file
    Loop
    

        If bShowBar Then Unload frmStatusBar
    
    Application.ScreenUpdating = True

End Sub
[/vba]

Проблема - неправильно рассчитывается процент выполнения. Скрипт % выполнения - кол-во обработанных файлов/кол-во всех найденных файлов в папке. Подскажите, пожалуйста, что нужно исправить для корректного отображения процента выполнения. Спасибо!
 
Ответить
СообщениеВсем привет. Я не эксперт vba, поэтому сразу сори, если у кого-то мой код вызовет судороги)) он слеплен из нескольких. Имеется:

Код полоски выполнения процентов:

[vba]
Код
Option Explicit
Public bShowBar As Boolean
Public dblProgressWidth As Double, dblStep As Double, dblPercent As Double
Sub MyProgresBar()
    dblProgressWidth = dblProgressWidth + dblStep
    frmStatusBar.FrameProgress.Width = dblProgressWidth
    If dblProgressWidth > dblPercent Then
        frmStatusBar.lblPercentWhite.Caption = Format(dblPercent / frmStatusBar.FramePrgBar.Width, "0%")
        frmStatusBar.lblPercentBlack.Caption = frmStatusBar.lblPercentWhite.Caption
        dblPercent = dblPercent + dblStep
        frmStatusBar.Repaint
        DoEvents
    End If
End Sub
Function Show_PrBar_Or_No(lCnt As Long, Optional sUfCaption As String = "Initializing")
    bShowBar = (lCnt > 10)
    If bShowBar = False Then Exit Function
    
    frmStatusBar.Caption = sUfCaption
    dblStep = frmStatusBar.FramePrgBar.Width / lCnt
    frmStatusBar.lblPercentWhite.Left = 96
    frmStatusBar.lblPercentBlack.Left = frmStatusBar.lblPercentWhite.Left
    
    frmStatusBar.Show 0
    dblPercent = 0: dblProgressWidth = 0
End Function
[/vba]

Код кнопки на открытие файлов в папке и копирования данных через добавление строки.

[vba]
Код
Sub Button1_Click()

    Dim c As Long
    [f1] = 0
    If Dir("C:\Users\andruha149\Desktop\Reports\My project\pmf macros\*.*") = "" Then Exit Sub Else c = 1
    Do
      If Dir = "" Then Exit Do Else c = c + 1
    Loop Until False
    [f1] = c
    

    Dim lr As Long
    Dim lAllCnt As Long
    lAllCnt = [f1]
    Call Show_PrBar_Or_No(lAllCnt, "Initializing...")
        
    Dim sFolder As String
    Dim sFile As String
    Dim wbD As Workbook, wbS As Workbook
     
    Application.ScreenUpdating = False
    Set wbS = thisWorkbook
    sFolder = wbS.Path & "\"
     
    sFile = Dir(sFolder)
   
    Do While sFile <> ""
        
        For lr = 0 To lAllCnt
        If bShowBar Then Call MyProgresBar
            Next
         
        If sFile <> wbS.Name Then
            Set wbD = Workbooks.Open(sFolder & sFile) 'open the file; add condition to
            wbD.Sheets("PMF").Range("A2:NS2").Copy
            wbS.Activate
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
            ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[1],RC[2]&""-""&RC[3])"
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormats
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
            wbD.Close savechanges:=True 'close without saving
        End If

         
        sFile = Dir 'next file
    Loop
    

        If bShowBar Then Unload frmStatusBar
    
    Application.ScreenUpdating = True

End Sub
[/vba]

Проблема - неправильно рассчитывается процент выполнения. Скрипт % выполнения - кол-во обработанных файлов/кол-во всех найденных файлов в папке. Подскажите, пожалуйста, что нужно исправить для корректного отображения процента выполнения. Спасибо!

Автор - Andruha149
Дата добавления - 25.07.2017 в 13:46
_Boroda_ Дата: Вторник, 25.07.2017, 15:19 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Что говорится в Правилах форума насчет кроссов?


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЧто говорится в Правилах форума насчет кроссов?

Автор - _Boroda_
Дата добавления - 25.07.2017 в 15:19
Andruha149 Дата: Вторник, 25.07.2017, 15:38 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
_Boroda_, кроссы это что?
 
Ответить
Сообщение_Boroda_, кроссы это что?

Автор - Andruha149
Дата добавления - 25.07.2017 в 15:38
_Boroda_ Дата: Вторник, 25.07.2017, 15:39 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщениеhttps://yandex.ru/search....&lr=213

Автор - _Boroda_
Дата добавления - 25.07.2017 в 15:39
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Некорректный расчет процента выполнения (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!