Question

我有word宏通过excel表， Excel

如图所示，它有几行（112），其中只有一行要执行操作，一行在WP列中有信息而在LS列中没有信息。

基本上我的代码所做的就是使用该行中的信息并将其放入我的模板word文件中的自定义变量中，然后保存名为LSXXXX的wordfile（此名称稍后会写回excel）。 LS XXXX文件如下所示：

LS FILE

此外，模板所需的一些信息来自另一个word文件（docOut）自定义属性，这也可以在下面看到： dokUt

代码有效，但速度极慢。我添加了代码来检查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

％value ：是您显示的进度百分比，将是您的＆＃34; ID＆＃34;与时间 True_or_False ：如果为True，则将其添加到时间表，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，我设法解决了性能问题。我在每个活动中制作了带有复选框的GUI。事实证明，问题是找到了永久性的列号，这在我的代码中是一个小错误：

    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

加速excel和word之间的互动

2 个答案: