Question

我有一个简单的宏，它在办公室的共享驱动器上添加了一个带目标的超链接。

因此，它只是逐行迭代并检查该值是否代表发票/日记和其他几个标准，并由此创建链接到驱动器中的文件夹和文件。

这在我有几百条记录的工作表上非常有效，但每当我在工作表中运行宏，我有几千条记录就会崩溃....

有谁知道如何解决这个问题？代码如下：

Sub Add_Hyperlink()

Application.ScreenUpdating = False

Dim sHeader, sDivision, sMonth, sPeriod, sPath As String
Dim FileName As String
Dim dLastRow As Double

dLastRow = Range("m1").End(xlDown).Row
If ActiveSheet.Name = "ABC" Then
sDivision = "???"
ElseIf ActiveSheet.Name = "BCD" Then
sDivision = "XXX"
ElseIf ActiveSheet.Name = "CDE" Then
sDivision = "XYZ"
End If


'petla sprawdzajaca kazda komorke

For i = 2 To dLastRow

Application.StatusBar = "Checking row no # " & i & " || Still " & dLastRow - i & "left to check"


'jesli dany wiersz jest Journalem
If Not Cells(i, "J") = "INV" And Not IsEmpty(Cells(i, "J")) Then
    sPeriod = Right(Cells(i, "E").Value, Len(Cells(i, "E")) - 1)
    sMonth = MonthName(sPeriod, False)
    sHeader = Cells(i, "L").Value
    If Len(sPeriod) = 1 Then
        sMonth = "P0" & sPeriod & " " & sMonth
    Else
        sMonth = "P" & sPeriod & " " & sMonth
    End If
    sPath = "G:\XXXXXXXXX" & sMonth & "\" & sDivision
    FileName = GetFileList(sPath & "\" & sHeader & "*")

    If Not FileName = "False" Then
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, "V"), Address:= _
    sPath & "\" & FileName, TextToDisplay _
    :=FileName
    End If
End If
Next

Application.StatusBar = False
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

Function GetFileList(FileSpec As String) As String
'      Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False

Dim FileArray() As String
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec, vbDirectory)
If FileName = "" Then GoTo NoFilesFound


GetFileList = FileName
Exit Function

'   Error handler
NoFilesFound:
GetFileList = False
End Function

当记录太多时，宏崩溃

0 个答案: