使用VBA解析CSV文件并写入工作表运行速度缓慢如何优化

核心性能问题原因 #

• 开启了屏幕更新：代码中Application.ScreenUpdating = True会导致每写入一个单元格就触发一次界面重绘，循环中频繁更新状态栏也会增加额外开销
• 逐单元格写入：VBA操作Excel单元格的COM接口开销极高，几千次单独写入的耗时远高于内存数组处理后一次性批量写入
• 未临时关闭自动计算、事件触发：写入数据时如果有工作表事件、公式自动计算，会被重复触发拖慢运行速度

优化后代码 #

Private Sub Workbook_Open()
    On Error GoTo ErrHandler
    ' 临时关闭Excel交互特性，大幅提升写入速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 首次请求获取cookie
    Dim objHttpRequest As Object
    Set objHttpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    objHttpRequest.Open "GET", "https://www.nseindia.com/reports/asm", False
    objHttpRequest.SetRequestHeader "REFERER", "https://www.nseindia.com/reports/asm"
    objHttpRequest.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
    objHttpRequest.Send
    
    ' 保存cookie供后续请求使用
    Dim strNSECookie As String
    strNSECookie = objHttpRequest.GetResponseHeader("Set-Cookie")
    
' 下载NSE ASM列表CSV文件
    objHttpRequest.Open "GET", "https://www.nseindia.com/api/reportASM?csv=true", False
    objHttpRequest.SetRequestHeader "REFERER", "https://www.nseindia.com/reports/asm"
    objHttpRequest.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
    objHttpRequest.SetRequestHeader "cookie", strNSECookie
    objHttpRequest.Send
    
    ' 解析CSV数据
    Dim arrNSEASMRecords As Variant, arrNSEASMRecordValues As Variant
    Dim intNSEASMRecordsCounter As Integer, intNSEASMSerialNumberCounter As Integer
    Dim strWorkSheetName As String, intNSEASMTotalRecords As Integer
    Dim arrLT As Variant, arrST As Variant, ltCount As Integer, stCount As Integer
    
    arrNSEASMRecords = Split(objHttpRequest.ResponseText, vbLf)
    intNSEASMTotalRecords = UBound(arrNSEASMRecords) - 1
    ' 预先初始化数组大小，预留足够空间
    ReDim arrLT(1 To intNSEASMTotalRecords, 1 To 5)
    ReDim arrST(1 To intNSEASMTotalRecords, 1 To 5)
    ltCount = 1: stCount = 1
    
    For intNSEASMRecordsCounter = 0 To intNSEASMTotalRecords
        arrNSEASMRecordValues = Split(arrNSEASMRecords(intNSEASMRecordsCounter), ",")
        If arrNSEASMRecordValues(0) = """Long Term""" Then
            strWorkSheetName = "LT"
            Worksheets(strWorkSheetName).UsedRange.ClearContents
        ElseIf arrNSEASMRecordValues(0) = """Short Term""" Then
            strWorkSheetName = "ST"
            Worksheets(strWorkSheetName).UsedRange.ClearContents
        ElseIf IsNumeric(arrNSEASMRecordValues(0)) Then
            If strWorkSheetName = "LT" Then
                arrLT(ltCount, 1) = Replace(arrNSEASMRecordValues(0), """", "")
                arrLT(ltCount, 2) = Replace(arrNSEASMRecordValues(1), """", "")
                arrLT(ltCount, 3) = Replace(arrNSEASMRecordValues(2), """", "")
                arrLT(ltCount, 4) = Replace(arrNSEASMRecordValues(3), """", "")
                arrLT(ltCount, 5) = Replace(arrNSEASMRecordValues(4), """", "")
                ltCount = ltCount + 1
            ElseIf strWorkSheetName = "ST" Then
                arrST(stCount, 1) = Replace(arrNSEASMRecordValues(0), """", "")
                arrST(stCount, 2) = Replace(arrNSEASMRecordValues(1), """", "")
                arrST(stCount, 3) = Replace(arrNSEASMRecordValues(2), """", "")
                arrST(stCount, 4) = Replace(arrNSEASMRecordValues(3), """", "")
                arrST(stCount, 5) = Replace(arrNSEASMRecordValues(4), """", "")
                stCount = stCount + 1
            End If
        End If
    Next
    ' 一次性写入两个工作表
    If ltCount > 1 Then Worksheets("LT").Range("A1:E" & ltCount - 1).Value = arrLT
    If stCount > 1 Then Worksheets("ST").Range("A1:E" & stCount - 1).Value = arrST
    
' 下载价格限制列表CSV文件
    Dim strNSEPBLatestFile As String, objDateCounter As Date
    objDateCounter = Now()
    ' 循环查找最新可用的文件
    Do
        strNSEPBLatestFile = "sec_list_" & Format(objDateCounter, "ddmmyyyy") & ".csv"
        objHttpRequest.Open "GET", "https://archives.nseindia.com/content/equities/" & strNSEPBLatestFile, False
        objHttpRequest.SetRequestHeader "REFERER", "https://www.nseindia.com/reports/asm"
        objHttpRequest.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
        objHttpRequest.SetRequestHeader "cookie", strNSECookie
        On Error Resume Next
        objHttpRequest.Send
        On Error GoTo ErrHandler
        objDateCounter = DateAdd("d", -1, objDateCounter)
    Loop While objHttpRequest.Status <> 200
    
    ' 解析价格列表CSV
    Dim arrNSEPBRecords As Variant, arrNSEPBRecordValues As Variant
    Dim intNSEPBRecordsCounter As Integer, intNSEPBTotalRecords As Integer
    Dim arrPB As Variant
    arrNSEPBRecords = Split(objHttpRequest.ResponseText, vbLf)
    strWorkSheetName = "Price Band"
    Worksheets(strWorkSheetName).UsedRange.ClearContents
    intNSEPBTotalRecords = UBound(arrNSEPBRecords) - 1
    ReDim arrPB(1 To intNSEPBTotalRecords + 1, 1 To 5)
    
    For intNSEPBRecordsCounter = 0 To intNSEPBTotalRecords
        arrNSEPBRecordValues = Split(arrNSEPBRecords(intNSEPBRecordsCounter), ",")
        arrPB(intNSEPBRecordsCounter + 1, 1) = Replace(arrNSEPBRecordValues(0), """", "")
        arrPB(intNSEPBRecordsCounter + 1, 2) = Replace(arrNSEPBRecordValues(1), """", "")
        arrPB(intNSEPBRecordsCounter + 1, 3) = Replace(arrNSEPBRecordValues(2), """", "")
        arrPB(intNSEPBRecordsCounter + 1, 4) = Replace(arrNSEPBRecordValues(3), """", "")
        arrPB(intNSEPBRecordsCounter + 1, 5) = Replace(arrNSEPBRecordValues(4), """", "")
    Next
    ' 一次性写入价格表
    Worksheets(strWorkSheetName).Range("A1:E" & intNSEPBTotalRecords + 1).Value = arrPB
    
ExitSub:
    ' 恢复Excel原有设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = ""
    Exit Sub
    
ErrHandler:
    MsgBox "错误：" & Err.Description
    Resume ExitSub
End Sub

优化效果说明 #

优化后所有写入操作改为内存数组处理后一次性批量写入，同时关闭了非必要的Excel交互特性，运行速度可以提升几十到上百倍，和手动打开CSV的加载速度基本一致。

内容的提问来源于stack exchange，提问作者Aadee Maanav