Question

我已经在这一段时间了，我已经让它快速工作，在几秒钟内通过几千行数据执行，但由于某种原因，它现在不断锁定在应用该范围的公式。

我已经尝试使用Index / Match和Vlookup并且两者都挂在同一点上。然后，我重新处理了整个事情，将所有数据读入几个数组，使用Application.Worksheetfunction完全在VBA中进行查找，并在转储回Excel之前将值返回到第三个数组，但我放弃了这个循环真的很乱。

代码如下所示，在它锁定时指出 - 总是在行.Formula =“***等等。道歉如果看起来有点凌乱，这是一项正在进行的工作，代码仍然需要整理。< / p>

有什么想法吗？

Sub ppmTracking()

On Error GoTo EndHere

Dim trPath

trPath = "C:\Users\hbartles\Desktop\PPM\Tracking Report\[MichPPMTracking3.xls]MichPPMTracking3"

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Sheets(1).Activate

'''''ORDER STATUS

    With Range("R2", Range("B2").End(xlDown).Offset(0, 16))
        .Formula = "=INDEX('" & trPath & "'!F:F, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With


'''''LINE STATUS

    With Range("S2", Range("B2").End(xlDown).Offset(0, 17))
        .Formula = "=INDEX('" & trPath & "'!G:G, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With

''''DESPATCH QUANTITY

    With Range("T2", Range("B2").End(xlDown).Offset(0, 18))
        .Formula = "=INDEX('" & trPath & "'!H:H, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        .Replace What:="0", Replacement:="", LookAt:=xlWhole
        .Interior.ColorIndex = xlNone
    End With

i = 2

    For Each cell In Range("T2", Range("B2").End(xlDown).Offset(0, 18))
        If Not cell.Text = "#N/A" Then
            If Not cell.Text = "" Then
                If cell.Value < Range("F" & i).Value Then cell.Interior.ColorIndex = 6
            End If
        End If
    i = i + 1
    Next cell



'''''DESPATCH DATE

    With Range("U2", Range("B2").End(xlDown).Offset(0, 19))
        .Formula = "=INDEX('" & trPath & "'!I:I, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        .NumberFormat = "General"
    End With

    For Each cell In Range("U2", Range("B2").End(xlDown).Offset(0, 19))
        cell.Value = cell.Value
    Next cell

    With Range("U2", Range("B2").End(xlDown).Offset(0, 19))
        .Replace What:="0", Replacement:="", LookAt:=xlWhole
        .NumberFormat = "m/d/yyyy"
    End With


'''''TRACKING NUMBER

    With Range("V2", Range("B2").End(xlDown).Offset(0, 20))
        .Formula = "=INDEX('" & trPath & "'!J:J, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))"
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        .Replace What:="0", Replacement:="", LookAt:=xlWhole
        .Replace What:="UPS", Replacement:="", LookAt:=xlPart
    End With

'''''FORMAT

    Cells.Font.Color = RGB(0, 0, 0)
    Rows(1).Font.Color = RGB(256, 256, 256)

    For j = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
        If Cells(j, 19).Text = "Cancelled" Then
            ActiveSheet.Range("R" & j).EntireRow.Font.ColorIndex = 3
            ActiveSheet.Range("U" & j, "V" & j).ClearContents
        End If
    Next

    Range("T2").Select
    Application.CutCopyMode = False



EndHere:



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic



End Sub

Answer 1

通常情况下，已经存在了好几天，一旦我在Stack Exchange上将其作为问题发布，我就会找到答案!!

当该文件采用XLS格式时，Excel不喜欢对外部文件进行查找。当我将查找文件保存为XLSX并在VBA中更改变量中的引用时，此代码现在很快。

现在回到Access的另一个问题，不想将查询数据导出为XLSX文件类型！

编辑：我在宏的开头添加了一些代码来打开文件，保存为xlsx并关闭它以备查找。现在运行顺利如黄油：）

Sub ppmTracking()

On Error GoTo EndHere

Dim chgPath
Dim trPath

chgPath = "C:\Users\hbartles\Desktop\PPM\Tracking Report\MichPPMTracking3.xls"
trPath = "C:\Users\hbartles\Desktop\PPM\Tracking Report\[MichPPMTracking3.xlsx]MichPPMTracking3"

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Application.DisplayAlerts = False

Workbooks.Open Filename:=chgPath
chgPath = Replace(chgPath, "xls", "xlsx")
ActiveWorkbook.SaveAs Filename:=chgPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close

Sheets(1).Activate
''And so on....

VBA坚持将一个公式粘贴到一个范围内

1 个答案: