Всем привет. Я не эксперт 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.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
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.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
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