VBA处理超百万数据(主要运用二维数组及字典)

class ImportorClass

    Option Explicit

    Private m_sht As Worksheet
    Private m_activecell As Range
    Private m_rowIndex As Long

    Private m_dictYjzh
    Private m_ksrq As Date
    Private m_jzrq As Date

    Private m_dictJsd

    Private m_rowset(1 To 100000, 1 To 10)

    Public Sub Init(sht As Worksheet, ksrq As Date, jzrq As Date, cjbfilename)
        Dim lastrow, title, tarr, i
        Set m_sht = sht
        m_ksrq = ksrq
        m_jzrq = jzrq

        lastrow = m_sht.Range("A" & m_sht.Cells.Rows.count).End(xlUp).Row
        If lastrow >= 2 Then
            m_sht.Range("2:" & lastrow).Delete
        End If
        title = "A1,A2,A3,A4,A5,A6,A7,A8,A9,A10"
        tarr = Split(title, ",")
        For i = LBound(tarr) To UBound(tarr)
            m_sht.Cells(1, i + 1) = tarr(i)
        Next
        Set m_activecell = m_sht.Range("a2")

        Set m_dictYjzh = GetCjb(cjbfilename)
    End Sub

    Sub SetRowSet(rowset, rowIndex, varr, myjzh, lx)

        rowset(rowIndex, 1) = "'" & varr(11)
        rowset(rowIndex, 2) = varr(12) 'wd
        rowset(rowIndex, 3) = varr(17)
        rowset(rowIndex, 4) = varr(18) 'zq
        rowset(rowIndex, 5) = varr(35) 'ys
        rowset(rowIndex, 6) = varr(37)
        
        rowset(rowIndex, 7) = m_dictYjzh(myjzh)(1)
        rowset(rowIndex, 8) = m_dictYjzh(myjzh)(2)
        rowset(rowIndex, 9) = m_dictYjzh(myjzh)(3)

        rowset(rowIndex, 10) = lx 

    End Sub

    'import jsd
    Sub ImportJsd(filename)
    
        Dim csvFile, yjzh
        Dim count, validCount, limitedCount, currLine, arr, ele, rq, objs, i, j
        Dim key As String
        csvFile = filename

        limitedCount = -20000 'testing
        count = 0
        validCount = 0

        m_rowIndex = 1

        Set m_dictJsd = CreateObject("Scripting.Dictionary")

        Open csvFile For Input As #1
        Do While Not EOF(1)
            Line Input #1, currLine
            
            If count <> 0 Then
                arr = GetArr(currLine)
                
                rq = DateValue(arr(17))
                If rq < m_ksrq Or rq > m_jzrq Then
                Else
                    yjzh = arr(11)

                    If IsEmpty(m_dictYjzh) Then
                    
                    ElseIf m_dictYjzh.exists(yjzh) Then
                        SetRowSet m_rowset, m_rowIndex, arr, yjzh, "jsd-" & count
                       
                        key = yjzh & arr(12) & arr(18) & arr(35)
                        If Not m_dictJsd.exists(key) Then m_dictJsd(key) = ""

                        m_rowIndex = m_rowIndex + 1
                        validCount = validCount + 1

                    End If
                End If
            End If
                    
            count = count + 1
            If limitedCount > 0 And count >= limitedCount Then Exit Do
        Loop
        
        Close #1
    
    End Sub

    Sub ImportYwd(filename)
        Dim csvFile, yjzh
        Dim count, validCount, limitedCount, currLine, arr, ele, rq, objs, i, j
        Dim key As String
        csvFile = filename

        limitedCount = -20000 'testing
        count = 0
        validCount = 0

        'm_rowIndex = 1

        Open csvFile For Input As #1
        Do While Not EOF(1)
            Line Input #1, currLine
            
            If count <> 0 Then
                arr = GetArr(currLine)
                
                rq = DateValue(arr(17))
                If rq < m_ksrq Or rq > m_jzrq Then
                Else
                    yjzh = arr(11)

                    If IsEmpty(m_dictYjzh) Then
                    
                    ElseIf m_dictYjzh.exists(yjzh) Then
                            
                        key = yjzh & arr(12) & arr(18) & arr(35)
                        If m_dictJsd.exists(key) Then
                        Else
                            SetRowSet m_rowset, m_rowIndex, arr, yjzh, "ywd-" & count
                               
                            m_rowIndex = m_rowIndex + 1
                            validCount = validCount + 1
                        End If
                    End If
                End If
            End If
                    
            count = count + 1
            If limitedCount > 0 And count >= limitedCount Then Exit Do
        Loop
        
        Close #1
    End Sub

    Public Sub WriteExcel()
        m_activecell.Resize(m_rowIndex - 1, 10) = m_rowset
    End Sub
    

    '获取cjb字典 key[zh] value[1 dq/2 dzr/3 xz]
    Function GetCjb(filename)
        Dim dict, csvFile, currLine, arr, count, cjbsj
        Set dict = CreateObject("Scripting.Dictionary")

        csvFile = filename

        Open csvFile For Input As #1

        count = 0
        Do While Not EOF(1)
            Line Input #1, currLine
            
            If count = 0 Then
            Else
                arr = GetArr(currLine)
                
                If Not dict.exists(arr(1)) Then 'B zh
                    ReDim cjbsj(1 To 3)
                    cjbsj(1) = arr(0) 'A dq
                    cjbsj(2) = arr(4) 'E dzr
                    cjbsj(3) = arr(5) 'F xz
                    dict(arr(1)) = cjbsj
                End If
                
            End If
            count = count + 1
        Loop
        Close #1
        Set GetCjb = dict
    End Function

    'seperator为逗号，考虑引号内有逗号的字段
    Function GetArr(str)
        If InStr(str, """") > 0 Then
            GetArr = GetSpecialArr(str)
            Exit Function
        Else
            GetArr = Split(str, ",")
        End If
    End Function

    '考虑引号内有逗号的字段
    Function GetSpecialArr(str)
        Dim i, arrQuote, temp, arr
        arrQuote = Split(str, """")
        For i = LBound(arrQuote) To UBound(arrQuote)
            If i Mod 2 = 1 Then
                arrQuote(i) = Replace(arrQuote(i), ",", "@@")
            End If
        Next
        temp = Join(arrQuote, """")
        arr = Split(temp, ",")
        For i = LBound(arr) To UBound(arr)
            If InStr(arr(i), "@@") > 0 Then
                arr(i) = Replace(arr(i), "@@", ",")
            End If
        Next
        GetSpecialArr = arr
    End Function

    Private Sub class_Initialize()
        ' Called automatically when class is created
    End Sub

    Private Sub class_Terminate()
        ' Called automatically when all references to class instance are removed
    End Sub

end class

class Main

    Option Explicit

    Sub Main()
        
        Dim im As ImportorClass, sht As Worksheet, filename, cjbfilename, t
        
        Debug.Print Now
        t = Timer
        
        Set sht = ActiveSheet
        Set im = New ImportorClass
        
        cjbfilename = "cjb.csv"
        im.Init sht, #7/1/2020#, #7/31/2020#, cjbfilename
        
        filename = "jsd.csv"
        im.ImportJsd filename
            
        filename = "ywd.csv"
        im.ImportYwd filename
        
        im.WriteExcel
        
        Set im = Nothing
        
        Debug.Print Now
        Debug.Print "耗时" & (Timer - t) & "秒"
    End Sub

    

end class