How to read first 5000 lines of .csv file into Excel using VBA code

Question

VBA Newbie:- I have large csv file . I would like to read only 5000 lines from it and import it into my excel using VBA.

I tried following code . It opens the file but I cant seem to find a way to import only 5000 rows

Sub importcsvfile()
    Dim WS As Worksheet, strFile As String
    Set WS = ActiveWorkbook.Sheets("sheet1") 'set to current worksheet name

    'Open .csv file'
    strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")

    With WS.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=WS.Range("A1"))
     .TextFileParseType = xlDelimited
     .TextFileCommaDelimiter = True
     .Refresh
    End With

    ' delete the querytable if there is one
    On Error GoTo nothingtodelete
    Sheets("Data").QueryTables(1).SaveData = False
    Sheets("Data").QueryTables.Item(1).Delete
    nothingtodelete:
End Sub

Code reference - https://stackoverflow.com/questions/12197274/is-there-a-way-to-import-data-from-csv-to-active-excel-sheet

Also, How do I save this file in .xlsm using VBA code .. Any help is appreciated!

Answer 1

I do not know if QueryTable method can be limited to a specific number of rows. But please, try this piece of code, instead. It should work and be fast enough:

Private Sub importcsvfile() 
    Dim WS As Worksheet, strFile As String, arrCSV, cols, dataCSV
    Dim i As Long, nL As Long, c As Long, nrRows As Long, strAll As String
    Dim st As Long, lEnd As Long
    
    Set WS = ActiveSheet
    nrRows = 5000
    
    'Open .csv file'
    strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")

    If strFile = "False" Then Exit Sub
    
    arrCSV = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(strFile, 1).ReadAll, vbLf) 'more than three minutes for this line...
    cols = Split(arrCSV(0), ",")
    ReDim dataCSV(0 To nrRows - 1, 0 To UBound(cols))
         
    nL = 0
    For i = 0 To nrRows - 1
        st = InStr(1, arrCSV(i), """"): lEnd = InStr(st + 1, arrCSV(i), """")
        If st > 0 Then
            arrCSV(i) = Replace(arrCSV(i), Mid(arrCSV(i), st, lEnd - st + 1), _
                        Replace(Mid(arrCSV(i), st + 1, lEnd - st - 1), ",", "/"))
        End If
        cols = Split(arrCSV(i), ",")
        For c = 0 To UBound(cols)
            dataCSV(nL, c) = cols(c)
        Next
        nL = nL + 1
    Next i
    
    WS.cells.Clear
    WS.Range("A1").Resize(nrRows, UBound(dataCSV, 2) + 1).Value = dataCSV
End Sub

Edited:

Please, check the next code which does not read the whole file string at once. I couldn't imagine that it is really huge... This version is very fast. It takes seconds. I will also let the first version only for learning reason. This should be the main purpose of our community, I think:

Private Sub importcsvfileRLines()
    Dim WS As Worksheet, strFile As String, arrCSV, cols, dataCSV
    Dim i As Long, nL As Long, c As Long, nrRows As Long, strAll As String
    Dim st As Long, lEnd As Long, myCSV As Object, txtLine As String
    
    Set WS = ActiveSheet 'use here the seet you need
    nrRows = 5000        'set here the number of rows to be returned
    
    'Open .csv file'
    strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")

    If strFile = "False" Then Exit Sub  'in case of pressing 'Cancel' button
    
    nL = 1 'initialize the first (array) row tot be filled
    ReDim dataCSV(1 To nrRows, 1 To 11)      'redim the necessary array (for big speed)
    Set myCSV = CreateObject("Scripting.FileSystemObject").OpenTextFile(strFile, 1)
        Do While myCSV.AtEndOfStream <> True 'iterate betweeb all existing lines
            txtLine = myCSV.ReadLine         'put the text line in a variable
            'solve the string problem, having comma delimiter between the double quotes:
            st = InStr(1, txtLine, """")     'position of the first double quotes character
            If st > 0 Then
                lEnd = InStr(st + 1, txtLine, """") 'position of the last double quotes character
                txtLine = Replace(txtLine, Mid(txtLine, st, lEnd - st + 1), _
                            Replace(Mid(txtLine, st + 1, lEnd - st - 1), ",", "/"))
            End If
            cols = Split(txtLine, ",")       'split the text on comma separator
            For c = 0 To UBound(cols)
                    dataCSV(nL, c + 1) = cols(c) 'fill the array nL row
            Next
            nL = nL + 1
            If nL = nrRows + 1 Then Exit Do      'if max set number of rows has been reached
        Loop
    myCSV.Close
    
    WS.cells.Clear 'clear the old data
    'drop the array value at once:
    WS.Range("A1").Resize(nrRows, UBound(dataCSV, 2)).Value = dataCSV
    MsgBox "Ready...", vbInformation, "Job finished"
End Sub