MyTetra Share
Делитесь знаниями!
Импорт очень большого текстового файла (>10 млн строк, и объем около 2 ГБ)
17.03.2018
21:41
Текстовые метки: k_Access->Excell,vba,ADO,Connection,Recordset
Раздел: VBA - Access - Access->Excell

другой человек сам их выгрузит из той же внешней системы

Вы правда не назвали, что это за система. Но всё равно не понимаю, если человек имеет к ней доступ, то кто мешает ему получать (в том числе и обновляемые) данные, используя SQL, в книгу Excel?
Например, для MS SQL Server

Код

    Const connStr As String = "ODBC;Driver={SQL Server Native Client 11.0};Server=(localdb)\mssqllocaldb;Database=SampleDb;Trusted_Connection=yes;"

    Dim pLO As ListObject, pSheet As Worksheet

    Set pSheet = ThisWorkbook.Worksheets.Add

    Set pLO = pSheet.ListObjects.Add(xlSrcExternal, connStr, True, xlYes, pSheet.Range("A1"))

    With pLO.QueryTable

        .CommandType = xlCmdSql

        .CommandText = "Select * From Production.Products"

        .Refresh

    End With



Естественно, CommandText может быть более сложным SQL запросом, чем в приведённом примере. Можно это же сделать и без программирования, задействовав MS Query.




Игорь, зря вы так по поводу SQL. Решил, коль целый день делать нечего с имитировать (упрощённо) задачу ТС. Создал два тестовых файла.
1. Users таблица клиентов ([UserName] ФИО - 16 символьное поле; [UserBirthday] Дата ФИО - дата).
2. UserData таблица покупок ([UserName] ФИО - 16 символьное поле; [DateBuy] Дата Покупки - дата; [Ammount] Сумма - плавающее).
Код был следующий

Скрытый текст

Код

Public Sub CreateUserTable()

    Dim fso As New Scripting.FileSystemObject

    Dim userStream As Scripting.TextStream

    Dim dataStream As Scripting.TextStream

    Dim pFuncs As WorksheetFunction, sDate As String

    Dim sUser As String, i As Long, k As Long

    Dim bStr(0 To 31) As Byte

    Set userStream = fso.CreateTextFile("c:\temp\user.csv", True)

    Set dataStream = fso.CreateTextFile("c:\temp\data.csv", True)

    Set pFuncs = Application.WorksheetFunction

    userStream.WriteLine "UserName,UserBirthday"

    dataStream.WriteLine "UserName,DateBuy,Amount"

    For i = 1 To 2000000

        For k = 0 To 31 Step 2

            bStr(k) = CByte(pFuncs.RandBetween(33, 96))

        Next

        sUser = bStr

        sUser = Replace$(sUser, ",", "_"): sUser = Replace$(sUser, """", "_")

        sDate = Format$(DateSerial(CInt(pFuncs.RandBetween(1930, 2010)), CInt(pFuncs.RandBetween(1, 12)), CInt(pFuncs.RandBetween(1, 28))), "dd.mm.yyyy")

        userStream.WriteLine sUser & "," & sDate

        For k = 1 To CLng(pFuncs.RandBetween(3, 9))

            sDate = Format$(DateSerial(CInt(pFuncs.RandBetween(1960, 2015)), CInt(pFuncs.RandBetween(1, 12)), CInt(pFuncs.RandBetween(1, 28))), "dd.mm.yyyy")

             dataStream.WriteLine sUser & "," & _

             sDate & "," & _

             Format$(1000# * Rnd, "0.00")

        Next

        If (i Mod 10000) = 0 Then

            DoEvents

            Debug.Print i

        End If

    Next

    dataStream.Close: userStream.Close

    MsgBox "end"

End Sub

 

Public Sub AddNotIn()

    Dim fso As New Scripting.FileSystemObject

    Dim userStream As Scripting.TextStream

    Dim dataStream As Scripting.TextStream

    Dim pFuncs As WorksheetFunction, sDate As String

    Dim sUser As String, i As Long, k As Long

     

    Set pFuncs = Application.WorksheetFunction

    Set dataStream = fso.OpenTextFile("c:\temp\data.csv", ForAppending)

    For i = 1 To 500000

        sUser = ""

        For k = 1 To 16

            sUser = sUser & Chr(CLng(pFuncs.RandBetween(183, 255)))

        Next

        For k = 1 To CLng(pFuncs.RandBetween(4, 9))

            sDate = Format$(DateSerial(CInt(pFuncs.RandBetween(1960, 2015)), CInt(pFuncs.RandBetween(1, 12)), CInt(pFuncs.RandBetween(1, 28))), "dd.mm.yyyy")

             dataStream.WriteLine sUser & "," & _

             sDate & "," & _

             Format$(1000# * Rnd, "0.00")

        Next

        If (i Mod 10000) = 0 Then

            DoEvents

            Debug.Print i

        End If

    Next

    dataStream.Close

End Sub



В Users 2 000 000 записей, в UserData 15 409 218 (часть записей для 500 000 ФИО отсутствует в Users). Собственно, задача отобрать в UserData ФИО, которых нет в Users (естественно, без повторений, так как в UserData могут быть сведения об нескольких покупках одного ФИО). В коде выше добавлены процедурой AddNotIn в UserData.

Попробовал сделать на словарях, вполне возможно, что допустил какую-то некорректность, код ниже, прошу дать оценку

Скрытый текст

Код

Public Sub TestDictionary2()

    Dim fso As New Scripting.FileSystemObject

    Dim pStream As Scripting.TextStream

    Dim userDict As New Scripting.Dictionary

    Dim notInDict As New Scripting.Dictionary

    Dim strOut() As String, readStr As String

    Dim sKey As Variant, i As Long, pSheet As Worksheet

    Dim t As Single

    t = Timer

    Set pStream = fso.OpenTextFile("c:\Temp\user.csv", ForReading)

    strOut = Split(pStream.ReadAll, vbCrLf)

    pStream.Close

    For i = 1 To UBound(strOut)

        userDict(Left$(strOut(i), 16)) = vbNullString

        If (i Mod 10000) = 0 Then

            DoEvents

            Debug.Print i

        End If

    Next

     

    Erase strOut

    Set pStream = fso.OpenTextFile("c:\Temp\data.csv", ForReading)

    strOut = Split(pStream.ReadAll, vbCrLf)

    pStream.Close

    For i = 1 To UBound(strOut)

        readStr = Left$(strOut(i), 16)

        If Not userDict.Exists(readStr) Then

            notInDict(readStr) = vbNullString

        End If

        If (i Mod 10000) = 0 Then

            DoEvents

            Debug.Print i

        End If

    Next

    Erase strOut

    ReDim strOut(1 To notInDict.Count, 1 To 1)

    i = 0

    For Each sKey In notInDict.Keys

        i = i + 1

        strOut(i, 1) = sKey

    Next

    Set pSheet = ThisWorkbook.Worksheets.Add

    pSheet.Range("A2").Resize(notInDict.Count, 1).Value = strOut

    pSheet.Range("A1").Value = "UserName"

    pSheet.Range("C1").Value = Timer - t

End Sub



Подождал некоторое время (минут 15) прервал.

Далее, загнал в Access, проиндексировал обе таблицы по полю UserName, далее следующим кодом получил результат за 65 секунд

Скрытый текст

Код

Public Sub CreateWithNonClustered()

    Const connStr As String = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Mode=1;Data Source=c:\Projects\Databases\Demo.accdb"

    Dim pLO As ListObject, pSheet As Worksheet

    Dim t As Single

    t = Timer

    Set pSheet = ThisWorkbook.Worksheets.Add

    Set pLO = pSheet.ListObjects.Add(xlSrcExternal, connStr, True, xlYes, pSheet.Range("A1"))

    With pLO.QueryTable

        .CommandType = xlCmdSql

        .CommandText = "SELECT DISTINCT UserData.UserName FROM UserData LEFT JOIN Users ON UserData.UserName = Users.UserName WHERE Users.UserName Is Null"

        .Refresh False

    End With

    pSheet.Range("C1").Value = Timer - t

End Sub



Ну, и тоже самое для этих же данных, помещённых в MS SQL LocalDb (естественно с индексами по UserName) - результат получен за 13 секунд

Скрытый текст

Код

Public Sub CreateWithNonClustered()

    Const connStr As String = "ODBC;Driver={SQL Server Native Client 11.0};Server=(localdb)\mssqllocaldb;Database=SampleDb;Trusted_Connection=yes;"

    Dim pLO As ListObject, pSheet As Worksheet

    Dim t As Single

    t = Timer

    Set pSheet = ThisWorkbook.Worksheets.Add

    Set pLO = pSheet.ListObjects.Add(xlSrcExternal, connStr, True, xlYes, pSheet.Range("A1"))

    With pLO.QueryTable

        .CommandType = xlCmdSql

        .CommandText = "Select Distinct tud.UserName From dbo.UserDataK tud Left Join dbo.UsersK tu On (tu.UserName=tud.UserName) Where tu.UserName Is Null"

        .Refresh False

    End With

    pSheet.Range("C1").Value = Timer - t

End Sub


Думаю, для столь объёмных данных выводы очевидны. Не забывайте использовать в базах данных индексы и строить запросы так, чтобы эти индексы задействовались.





Реализовал свою идею через Словари. Скорость приемлемая, за исключением последнего шага. В котором я пытаюсь сохранить Словарь в файл. На меленьких файлах скорость приемлемая, но когда размер справочника 4 млн строк, а размер занимаемой памяти Excel около 1 Гб, сохранение идет очень долго - в минуту не более 1000 строк  :

Код

Public Sub ClosePensSprav(FileName As String)

Dim txtFile As TextStream

Dim TmpString As String

Dim Ndx As Long

Dim lLowVal As Long

Dim lHighVal As Long

Dim lStep As Long

 

    If Not (FSO.FileExists(FileName)) Then FSO.CreateTextFile (FileName)

    Set txtFile = FSO.OpenTextFile(FileName, ForWriting)

     

    lHighVal = PensSprav.Count

    lStep = CLng(lHighVal / 100)

     

    For Ndx = 0 To PensSprav.Count - 1

 

        lLowVal = Ndx

        If lLowVal Mod lStep = 0 Then Application.StatusBar = "Сохранение справочника:" & FSO.GetFileName(FileName) & ": " & sObrStr(lLowVal, lHighVal) & sSuff(CInt(lLowVal / lHighVal * 100))

 

        TmpString = PensSprav.Keys(Ndx) & "|" & PensSprav.Items(Ndx)

        txtFile.WriteLine (TmpString)

        DoEvents

    Next Ndx

     

    txtFile.Close

    Application.StatusBar = False

    Set txtFile = Nothing

    Set PensSprav = Nothing

 

End Sub



 

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования