Ускорение взаимодействия между первенствую слово

Question

У меня слово макрос, который scolls через лист Excel,

Как видно он имеет несколько рядов (112), где существует только одна строка, которая должна быть выполнена действие на, тот, у кого есть информация в столбце WP, и информация отсутствует в столбце LS.

Так что в основном мой код - это использовать информацию в этой строке и помещать ее в пользовательские переменные в файл слова шаблона, а затем сохранять текстовый файл с именем LSXXXX (это имя позже записывается в excel). Файл LS XXXX можно увидеть ниже:

Кроме того, некоторые из информации, необходимой для шаблона происходит от другого слова файла (docOut) пользовательских свойств это можно было видно ниже, а:

Код работает, но его чрезвычайно медленно. Я добавил код, чтобы проверить, открыт ли excel другими пользователями, для параметра screenupdating установлено значение false.

Любая идея, как я могу ускорить мой код? Если я использую ссылку на библиотеку excel, это означает, что каждый пользователь, который использует мою библиотеку, должен добавить ссылку на нее сам по себе, и, следовательно, раннее связывание не является действительно практичным.

Ниже фрагменты из моего кода:

Dim i As Integer 
Dim oXLApp As Object 
Set oXLApp = CreateObject("Excel.Application") 


Dim xlapp As Object 
'~~> Hide Excel 
oXLApp.Visible = False 



Dim temp As Variant 


'Dictionary with all types 
Set temp = getTypes(Settings.userNameFile) 


projectnumber = GUI.ComboBoxProjectnumberLogScheme.Value 
initGUI.closeGUI 

dokut = FileHandling.getDocOutName(projectnumber) 
On Error Resume Next 

If Not FileHandling.openDocument(dokut) Then 
    MSG = MsgBox("Doc out does not exist, create it?", vbYesNo, "Creater") 
    'ask if the user really knows what he is doing... 
    If MSG = vbYes Then 

     If Not FileHandling.createDocument(projectnumber) Then 
      MsgBox "Failed to create document, sorry mate" 
      GoTo Terminate: 
     End If 

    Else 
     GoTo Terminate: 
    End If 
End If 

tittel = Documents(dokut).CustomDocumentProperties("ProsjektTittel") 

If tittel = "" Then 
    ' Promt user to input title 
    tittel = InputBox("Type the project title") 
    'ask if the user really knows what he is doing... 
    If tittel = "" Then 
     GoTo Terminate: 
    Else 
     Call createCustomDocumentProperty(dokut, "ProsjektTittel", tittel, msoPropertyTypeString) 
    End If 
End If 

subject = "Logg skjema" 
company = Documents(dokut).CustomDocumentProperties("_Company") 
myKeywords = Documents(dokut).CustomDocumentProperties("_Keywords") 
avsender = temp(Environ$("Username")) 
ceo = Documents(dokut).CustomDocumentProperties("CEO") 
customer = Documents(dokut).CustomDocumentProperties("Customer") 

If customer = "" Or customer = "Customer" Then 
    ' Promt user to input title 
    customer = InputBox("Type the name of the customer") 
    'ask if the user really knows what he is doing... 
    If customer = "" Then 
     GoTo Terminate: 
    Else 
     Call createCustomDocumentProperty(dokut, "Customer", customer, msoPropertyTypeString) 
    End If 
End If 


myFileName = Settings.projectFolder & projectnumber & "\" & Settings.partsList 

If Dir(myFileName) = "" Then 
    MsgBox "The parts list does not exist, manually copy it over please or rename it to : " & vbNewLine & myFileName 
    Exit Sub 
End If 

Dim Ret 

Ret = LogScheme.IsWorkBookOpen(myFileName) 

If Ret = True Then 
    MsgBox "Partslist is open, close it and try again" 
    GoTo Terminate 
End If 

Set xlapp = oXLApp.Workbooks.Open(myFileName) 'Filename:=file-path, ReadOnly:=True 
xlapp.Application.ScreenUpdating = False 
'oXLApp.Visible = False 


numofrows = LogScheme.firstBlankRow(xlapp) 
columnWp = LogScheme.getColumn("WP", xlapp) 
columnDrawing = LogScheme.getColumn("Drawing", xlapp) 
columnQuantity = LogScheme.getColumn("Quantity", xlapp) 
columnCommonName = LogScheme.getColumn("Common", xlapp) 
columnMaterial = LogScheme.getColumn("Material", xlapp) 
columnMaterialCertificate = LogScheme.getColumn("Certificate", xlapp) 
columnCustomerRequirements = LogScheme.getColumn("Customer", xlapp) 
columnMOM = LogScheme.getColumn("MOM", xlapp) 
columnSerie = LogScheme.getColumn("Serie", xlapp) 
columnLogSchema = LogScheme.getColumn("LS", xlapp) 
columnSupplierMaterial = LogScheme.getColumn("Location", xlapp) 
columnRevision = LogScheme.getColumn("Revision", xlapp) 

If numofrows < 3 Or IsEmpty(numofrows) Then 
    MsgBox "The partslist is empty, no logscheme can be produced" 
    GoTo Terminate 
End If 

j = 0 
ProgressBar.Show vbModeless 
For i = 3 To numofrows 
    sPercentage = (i/numofrows) * 100 
    ProgressBar.progress (sPercentage) 
    If Not IsEmpty(xlapp.sheets("List").Cells(i, columnWp).Value) And IsEmpty(xlapp.sheets("List").Cells(i, columnLogSchema).Value) Then 
     j = j + 1 
     Call main.NewFile(3, projectnumber, xlapp.sheets("List").Cells(i, columnCommonName).Value, xlapp.sheets("List").Cells(i, columnDrawing).Value, avsender) 
     docTemplate = ActiveDocument.Name 

     'get properties from excel 
     Documents(docTemplate).CustomDocumentProperties("WP") = xlapp.sheets("List").Cells(i, columnWp).Value 

некоторый код, а затем очистки:

Unload ProgressBar 

MsgBox "Created " & j & "New Log Schemes" 

xlapp.Application.ScreenUpdating = True 
xlapp.ActiveWorkbook.Close (True) 
xlapp.Quit 
Set xlapp = Nothing 
Set oXLApp = Nothing 

' Do all on the doc out document..... 
dokut = FileHandling.getDocOutName(projectnumber) 

If FileHandling.openDocument(dokut) Then 
    Call initGUI.closeGUI 
    Call searchAll("LS") 
Else 
    MsgBox "Did not find any dokument with that number, sorry mate." 
End If 

Application.ScreenUpdating = True 
Documents(dokut).Activate 
Documents(dokut).Save 

Terminate: 
    initGUI.closeGUI 
    Exit Sub 

код использует этот код, чтобы проверить, если файл Excel открыт другим пользователем:

Function IsWorkBookOpen(FileName As String) 
Dim ff As Long, ErrNo As Long 

On Error Resume Next 
ff = FreeFile() 
Open FileName For Input Lock Read As #ff 
Close ff 
ErrNo = Err 
On Error GoTo 0 

Select Case ErrNo 
Case 0: IsWorkBookOpen = False 
Case 70: IsWorkBookOpen = True 
Case Else: Error ErrNo 
End Select 
End Function 

и эта функция, чтобы найти первую пустую строку/последнюю строку + 1:

Function firstBlankRow(ByRef xlapp) As Long 
'returns the row # of the row after the last used row 
With xlapp.sheets("List") 
    firstBlankRow = .Range("A1").Offset(.Rows.Count - 1, 0).End(xlUp).Row + 1 
End With 
End Function 

Answer 1

Чтобы использовать его, поместите это в коде:

UpdateProg %value, True_or_False 

% Значение: Ваш отображается процент прогресса, и будет ваш «ID» с таймингами true_or_false: Правда добавить это в таблицу времени, False только обновить индикатор выполнения

Вот форма, используемая для запуска мастер-макроса, отображения прогресса и рассказать вам, сколько всего было сделано. ZIP with form and code Единственное, что вам нужно сделать, это сменить MasterMacro с названием вашей основной процедуры. (Вы не пропустите его в коде формы)

Вот код, который нужно поместить в модуль, то есть наиболее полезные функции, используемые в форме Launcher.

Public Progression As Double 
Public StarTTime As Double 

Sub ClickToLaunch() 
    ThisWorkbook.Save 
    Launcher.Show 
End Sub 

Public Sub UpdateProg(ByVal Value As Long, ByVal Timing As Boolean) 
    If Value <> 0 Then 
    Else 
     StarTTime = Timer 
    End If 

    Launcher.Image_barre.Width = Value * 1.5 
    Launcher.Label_barre.Caption = Format(Value, "##0,0") & "%" 
    DoEvents 

If Timing Then 
    TimT(0, UBound(TimT, 2)) = Value 
    TimT(1, UBound(TimT, 2)) = Timer - StarTTime 
    TimT(2, UBound(TimT, 2)) = Timer - TimT(1, UBound(TimT, 2) - 1) - StarTTime 
    ReDim Preserve TimT(UBound(TimT, 1), UBound(TimT, 2) + 1) 
Else 
End If 

End Sub 


Public Sub Print2D_Array(ByVal ArrayT As Variant, ByVal SheetName As String) 

DeleteAndAddSheet SheetName 

For I = LBound(ArrayT, 1) To UBound(ArrayT, 1) 
    For j = LBound(ArrayT, 2) To UBound(ArrayT, 2) 
     Sheets(SheetName).Cells(I + 1, j + 1) = ArrayT(I, j) 
    Next j 
Next I 


End Sub 


Public Function DeleteAndAddSheet(ByVal SheetName As String) As Worksheet 

For Each aShe In Sheets 
    If aShe.Name <> SheetName Then 
    Else 
     Application.DisplayAlerts = False 
     aShe.Delete 
     Application.DisplayAlerts = True 
     Exit For 
    End If 
Next aShe 

Sheets.Add after:=Sheets(Sheets.Count) 
Sheets(Sheets.Count).Name = SheetName 

Set DeleteAndAddSheet = ThisWorkbook.Worksheets(Worksheets.Count) 

End Function 

Answer 2

Благодаря R3Uk мне удалось решить проблему с производительностью. Я сделал графический интерфейс с флажками на каждом событии.И получится, что проблема найти номер столбца, который взял навсегда, это аа небольшая ошибка в моем коде:

Public Function getColumn(header As String, ByRef xlApp) As Long 
     Dim rng1 As Object 
     With xlApp.Sheets("List") 
      ' was .Range(.Cells(2, 1), .Cells(1, .Columns.Count)) 
      Set rng1 = .Range(.Cells(2, 1), .Cells(2, .Columns.Count)) 
      If rng1 Is Nothing Then 
      MsgBox ("ERROR: Range object is empty.") 
      getColumn = -1 
      Exit Function 
      End If 
      For Each m In rng1 
      If InStr(UCase(CStr(m)), UCase(header)) Then 
      getColumn = m.Column 
      Exit Function 
      End If 
      Next m 
      MsgBox "Column " & header & " does not exist, Typo??", vbCritical 
      getColumn = -1 
     End With 
    End Function 

Походивший, что поиск текста, чтобы соответствовать столбец в целом листе вместо строка заголовка, и, следовательно, потребовалось более 1 минуты, чтобы найти все индексы столбцов. Я также прилагается код для заполнения GUI флажков в случае чьего ребра это полезно, это помогло мне много :)

Sub DebuggerGUI(CheckBoxNumber, stateMy As Boolean, deltaTime, Optional ByVal numberLS As Integer = -1) 

Dim contr As control 
Dim logText As String 
logText = "" 

For Each contr In LS.Controls 
    If TypeName(contr) = "CheckBox" And InStr(contr.name, CheckBoxNumber) Then 
     contr.Value = stateMy 

     If Not numberLS = -1 Then 
      logText = " - Number of LS created: " & CStr(numberLS) 
     End If 
     contr.Caption = contr.Caption & deltaTime & logText 
     LS.Hide 
     LS.Show vbModeless 
    End If 
Next 


End Sub