Панель процесса в VBA не работает

Question

У меня есть макрос, который преобразует/создает листы на основе листа данных в книге. В зависимости от спецификации может создаваться от 3 до 50 новых листов. Когда есть только данные для трех листов, они работают довольно быстро, но когда у меня есть данные для 50 новых листов, это занимает немного времени, и я хочу, чтобы пользователь знал, насколько быстро процесс - это строка состояния/процесса. Я использовал Ejaz 'approach и загрузил пользовательскую форму, а также модуль в свою книгу. Я пытался объединить его с моим кодом, который выглядит следующим образом:

Option Explicit 

Sub convert_click() 

Application.EnableEvents = False 
Application.ScreenUpdating = False 

Dim wsMaster As Worksheet, wsShift As Worksheet 
Dim lRow&, mRow& 
Dim shift$, person$, day$, desc$, typee$, shiftName$ 
Dim sRow&, sCol& 
Dim oFind As Range 
Dim bNedfald As Boolean, newCol$ 

newCol = FrontSheet.Range("FP_Column") 
If newCol = "" Then 
    MsgBox "Please specify column", vbCritical 
    FrontSheet.Range("FP_Column").Activate 
    Exit Sub 
End If 

LogSheet.ListObjects(1).ListColumns("Linenumber").Range(1, 1).Offset(0, 1) = newCol 
LogSheet.ListObjects(1).ListColumns("Linenumber2").Range(1, 1).Offset(0, 1) = newCol 

newCol = IIf(newCol = "EU", "M", "N") 

' delete existing sheets before creating new one 
Call deleteShiftSheets 

START 

Set wsMaster = ThisWorkbook.Sheets("Master") 

With wsMaster 
    If wsMaster.FilterMode Then wsMaster.ShowAllData 
    lRow = .Cells(Rows.Count, "A").End(xlUp).row 

    For mRow = 2 To lRow 
     ' read data from master 
     shift = Trim(.Cells(mRow, "A")) 
     shiftName = IIf(.Cells(mRow, "F") = "", .Cells(mRow, "E"), .Cells(mRow, "F")) 
     desc = Trim(.Cells(mRow, "B")) 
     person = Trim(.Cells(mRow, "C")) 
     day = Trim(.Cells(mRow, "D")) + 1 
     typee = UCase(Trim(.Cells(mRow, "E"))) 
     sCol = person + 2 
     sRow = (day * 8) 

     ' get reference of existing sheet or create new one 
     Set wsShift = getWorksheet(ActiveWorkbook, shift, desc) 

     If InStr(1, desc, "nedfald", vbTextCompare) Then 
      bNedfald = True 
     End If 

     If wsShift.Cells(7, sCol) = "" Then 
      TemplateSheet.Range("Block").Copy 
      'wsShift.Cells(7, sCol).PasteSpecial 
      wsShift.Cells(7, sCol).Insert xlShiftToRight 
     End If 
     If wsShift.Cells(7, sCol) = "" Then wsShift.Cells(7, sCol) = person 

     ' popualte data from master to shift sheet 
     wsShift.Cells(sRow, sCol) = shiftName 
     wsShift.Cells(sRow + 1, sCol) = .Cells(mRow, "H") 
     wsShift.Cells(sRow + 2, sCol) = .Cells(mRow, "I")  
     wsShift.Cells(sRow + 3, sCol) = .Cells(mRow, "J")  
     wsShift.Cells(sRow + 4, sCol) = .Cells(mRow, "L")  
     wsShift.Cells(sRow + 5, sCol) = .Cells(mRow, "K") 
     wsShift.Cells(sRow + 6, sCol) = .Cells(mRow, newCol)  
     wsShift.Cells(sRow + 7, sCol) = .Cells(mRow, "O")  

Call modProgress.ShowProgress(0, wsShift, _ 
       "Excel is working on Task Number 1", False, _ 
       "Progress Bar Test") 

    Next 
End With 

Call ignoreErrors 
Call addButtons 
Call protectSheets 
Call validateRules 
Call hideBlankPartStay 


If Not bNedfald Then 
    Call getWorksheet(ActiveWorkbook, "nedfald", "nedfald") 
End If 

FrontSheet.Activate 
FINISH 

Application.ScreenUpdating = True 
Application.EnableEvents = True 

''MsgBox "sheets generated", vbInformation 
End Sub 


' this function either retuns existing worksheet if already exists or create a new one and then return it 
Function getWorksheet(wbFile, sheetName$, desc) As Worksheet 
    Dim t As Worksheet 
    On Error GoTo Sheet_Not_Found 
    sheetName = sheetNameSafeString(sheetName) 
Set getWorksheet = wbFile.Sheets(CStr(sheetName)) 
Exit Function 

Sheet_Not_Found: 
    TemplateSheet.Visible = xlSheetVisible 
    ' add new shift sheet 
    TemplateSheet.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 
    TemplateSheet.Visible = xlSheetHidden 
    Set getWorksheet = ActiveSheet 
    ActiveSheet.Range("ShiftName") = sheetName 
    ActiveSheet.Range("Description") = desc 
    ActiveSheet.Tab.ColorIndex = -4142 
    ActiveSheet.Name = sheetName 
' this identifies it as shift sheet. 
ActiveSheet.Range("Z1") = "Shift_Sheet" 
DoEvents: DoEvents 

If desc = "nedfald" Then 
    ActiveSheet.Shapes("shTransfer").Delete 
End If 
End Function 

' delete existing shift sheets. 
Sub deleteShiftSheets() 
Dim ws As Worksheet 

Application.DisplayAlerts = False 
For Each ws In ThisWorkbook.Sheets 
    If ws.Range("Z1") = "Shift_Sheet" Then 
     ws.Delete 
    End If 
Next 
Application.DisplayAlerts = True 
End Sub 

Когда я запускаю макрос, то он дает мне эту ошибку:

«Ошибка выполнения„438“: Object Безразлично» т поддерживает это свойство или метод»

И выдвигает на первый план следующую строку:

Call modProgress.ShowProgress(0, wsShift, _ 
       "Excel is working on Task Number 1", False, _ 
       "Progress Bar Test") 

Что я делаю неправильно?

(я использовал код Эджаз»в модуле modProgress, как это. Должен ли я загрузить его здесь?)

Thx!

Answer 1

Вы используете Worksheet object, где функция ожидает общее количество задач и статический нуль для текущего индекса числовой задачи.

Call modProgress.ShowProgress(mRow, lRow, _ 
       "Excel is working on Task Number 1", False, _ 
       "Progress Bar Test") 

Я использовал mRow и lRow в вашем For Each...Next Statement для обеспечения текущей задачи и общее количество задач. Это должно быть достаточно близко, хотя вы можете уменьшить как на 1 (mRow начинается с 2).