Question

我有一个宏，该宏从外部源检索一些数据，然后创建一个包含数据的CSV文件。然后，它会检查这是否是最新数据，如果不是，则再次循环以上操作。

这通常可以正常工作，但是如果有大量积压的数据要处理，我注意到它偶尔会在此丢失文件。

我尝试过记录日志以检查是否发生了乱序，但似乎并非如此。该日志甚至记录了丢失文件的创建。

据我了解，VBA并非异步运行。那是怎么回事？我如何查明问题，该怎么办？

编辑：问题原来是相当愚蠢的。由于文件是使用当前时间命名的（仅精确到秒），因此某些文件是在同一秒内创建的，因此相互覆盖。我已经更改了文件命名格式。

感谢您指出我对错误处理（或缺少错误处理）的错误使用。

我的代码：

Option Explicit

Public DebugMode As Boolean
Public TestMode As Boolean

Private Sub Workbook_Open()

Dim piServer        As PISDK.Server
Dim connection      As Boolean
Dim connectionTries As Integer
Dim dataTime        As Date
Dim currentTime     As Date
Dim rowNo           As Integer

'Set to True to enable logging to debug.txt
DebugMode = True
'Set to True to write output only to Test Output folder
TestMode = False

WriteLogs ("Successfully opened GCS_Handoff.xls")

Set piServer = PISDK.Servers(Range("piServer").Value)
connection = False
connectionTries = 0

PI_Reconnect:

'If PI Server is not connected...
If Not piServer.Connected Then

WriteLogs ("Connecting to PI Server at " & Range("piServer").Value & "...")

    On Error Resume Next
    Err.Clear

    'Connect to PI Server
    'Call piServer.Open("UID=" & "piadmin" & ";PWD=" & "password")
    Call piServer.Open

    'If connection attempt to PI Server was not successful..
    If Err.Number <> 0 Then

        'Pause for 20 seconds
        Application.Wait DateAdd("s", 20, Now)
        'Increment count
        connectionTries = connectionTries + 1

        'Retry 5 times
        If connectionTries <= 5 Then
            GoTo PI_Reconnect:
        Else
            '5th attempt failed... quit Excel
            WriteLogs ("Failed to connect to PI")
            GoTo Exit_App:
        End If

    End If

    WriteLogs ("Successfully connected to PI")

End If

dataTime = Range("DataTime").Value
'Current time round to nearest half hour
currentTime = Round(Now() * 48, 0) / 48

'Repeat the following until current time reached
Do While dataTime < currentTime

    'Increment the data time by 30 minutes
    dataTime = DateAdd("n", 30, dataTime)

    WriteLogs ("Starting " & dataTime)

    'The row containing the first tag
    rowNo = 2

    'While there is a value in column A of the current row
    Do While IsEmpty(Sheets("Data").Range("A" & rowNo).Value) = False

        'Clear the previous data
        Sheets("Data").Range(Cells(rowNo, 2), Cells(rowNo, 3)).ClearContents

        'Read the tag in column A and write the PI value in column C
        Sheets("Data").Range(Cells(rowNo, 2), Cells(rowNo, 3)) = _
            Application.Run("PIArcVal", Sheets("Data").Range("A" & rowNo).Value, dataTime, 1, piServer, "auto")

        rowNo = rowNo + 1
    Loop

    'Update the last data write timestamp
    Range("DataTime").Value = dataTime

    WriteLogs ("Successfully retrieved PI data in GCS_Handoff.xls")

    'Write to CSV
    Call WriteToCSV(dataTime, rowNo)

Loop

Exit_App:

    'Cleanup...
    Set piServer = Nothing

    'Stop alerts
    'Close workbook (and Excel if no other workbooks are open)
    If Workbooks.Count > 1 Then

        WriteLogs ("Multiple workbooks open.  Closing GCS_Handoff.xls...")

        Application.DisplayAlerts = False
        ThisWorkbook.Close True

        WriteLogs ("Successfully closed GCS_Handoff.xls")

    Else

        WriteLogs ("Quitting Excel...")

        Application.DisplayAlerts = False
        Application.Quit

        WriteLogs ("Successfully quit Excel")

    End If

End Sub

Sub WriteToCSV(ByVal timeStamp, ByVal emptyRow)

Dim fso             As FileSystemObject
Dim fileTime        As String
Dim outputFile      As File
Dim outputPath      As String
Dim txtStream       As TextStream
Dim i               As Integer
Dim line            As String

Set fso = New FileSystemObject

'In Test Mode, write the file to the Test folder
If TestMode = True Then
    outputPath = Range("ApplicationPath").Value & "Test Output\"
Else
    outputPath = Range("ApplicationPath").Value & "Output\"
End If

On Error Resume Next

fileTime = Format(Now, "yyyy-MM-dd_hh-mm-ss")

WriteLogs ("Creating CSV file...")

'Create the output CSV file
Set outputFile = fso.CreateTextFile(outputPath & "GCS_PI_" & fileTime & ".csv")

WriteLogs ("CSV file created")

Set outputFile = fso.GetFile(outputPath & "GCS_PI_" & fileTime & ".csv")
Set txtStream = outputFile.OpenAsTextStream(ForWriting)

WriteLogs ("Writing CSV file...")

'Loop through the data cells and write each one on a new line
With txtStream
    .WriteLine timeStamp
    For i = 2 To emptyRow - 1
        line = Sheets("Data").Range("A" & i).Value & "," & Sheets("Data").Range("C" & i).Value

        If i < emptyRow - 1 Then
            'Write the line and a line return character
            .WriteLine (line)
        Else
            'If this is the final line
            .Write (line)
        End If
    Next
    .Close
End With

WriteLogs ("CSV file written")

WriteLogs ("Finishing " & timeStamp)

'Cleanup...
Set fso = Nothing
Set outputFile = Nothing
Set txtStream = Nothing

End Sub

Sub WriteLogs(ByVal logText)

Dim fso         As FileSystemObject
Dim logFile     As File
Dim txtStream   As TextStream
Dim logPath     As String

'If running in Debug Mode
If DebugMode = True Then

    Set fso = New FileSystemObject
    logPath = Range("ApplicationPath").Value & "Logs\"

    On Error Resume Next

    'Get the log file
    Set logFile = fso.GetFile(logPath & "debug.txt")

    'If the file doesn't exist, create it
    If Err <> 0 Then
        Set logFile = fso.CreateTextFile(logPath & "debug.txt")
        Set logFile = fso.GetFile(logPath & "debug.txt")
    End If

    Set txtStream = logFile.OpenAsTextStream(ForAppending)

    'Write the current time and the log text
    With txtStream
        .WriteLine Now() & " " & logText
        .Close
    End With

    'Cleanup...
    Set fso = Nothing
    Set logFile = Nothing
    Set txtStream = Nothing

End If

End Sub

Answer 1

问题原来是愚蠢的，是我而不是VBA引起的。由于文件是使用当前时间命名的（仅精确到秒），因此某些文件是在同一秒内创建的，因此相互覆盖。我已经更改了文件命名格式。

感谢您指出我对错误处理（或缺少错误处理）的错误使用。

Excel VBA是否异步运行？

1 个答案: