importLargeFile:   <back to snippets>   <back to tools>

Option Explicit
Dim strFile As String

Sub doLoad()
    Call setGearz
End Sub

Sub setGearz
    Application.StatusBar = "ASCII Fileimporter v 0.5.0 by tatze - www.gearz.de"
End Sub

Sub openFile()
    strFile = Application.GetOpenFilename
    Range("E7").Value = strFile
End Sub


Sub addData()
    Dim intRow As Integer
    Dim intCol As Integer
    Dim intLineCount As Double
    Dim intMaxLines As Double
    Dim intTotalLines As Double
    Dim strTxt As String
    Dim strFileName As String
    Dim strWorkbook As String
    Dim strSeperator As String

    intMaxLines = 30000

    If strFile = "" Or Range("e7").Value = False Then
        MsgBox "Please choose a file to import", vbCritical, "err99"
        Exit Sub
    End If

    strSeperator = Range("A23").Value
    Select Case (strSeperator)
    Case 1
        strSeperator = Chr(44)  ' comma
    Case 2
        strSeperator = Chr(9)   ' tab
    Case 3
        strSeperator = Chr(32)  ' space
    Case 4
        strSeperator = Chr(59)  ' semicolon
    Case 5
        strSeperator = Chr(38)  ' &
    Case Else
        strSeperator = Chr(9)
    End Select
    Range("A11").Value = "Importing, please wait ..."
    Application.ScreenUpdating = False
    Close
    intLineCount = intMaxLines
    Open strFile For Input As #1
      Do Until EOF(1)
         If intLineCount >= intMaxLines Then
            ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
            intLineCount = 1
            intRow = 1
            intCol = 1
            Application.StatusBar = "Importing Sheet " & ActiveWorkbook.Sheets.Count - 1
         End If
         Line Input #1, strTxt
         Do While InStr(strTxt, strSeperator)
            If strSeperator = Chr(44) Then
                Cells(intRow, intCol).Value = Left(strTxt, InStr(strTxt, strSeperator) - 1)
            Else
                If strSeperator = Chr(38) Then
                    strTxt = Replace(Replace(strTxt, "\", ""), Chr(9), "")
                End If
                If ActiveWorkbook.Sheets("import_excel").Range("C23").Value = True Then
                    Cells(intRow, intCol).Value = Replace(Left(strTxt, InStr(strTxt, strSeperator) - 1), ",", ".")
                Else
                    Cells(intRow, intCol).Value = Replace(Left(strTxt, InStr(strTxt, strSeperator) - 1), ",", "")
                End If
            End If
            strTxt = Right(strTxt, Len(strTxt) - InStr(strTxt, strSeperator))
            intCol = intCol + 1
        Loop
        If strSeperator = Chr(44) Then
            Cells(intRow, intCol).Value = strTxt
        Else
            If strSeperator = Chr(38) Then
                strTxt = Replace(Replace(strTxt, "\", ""), Chr(9), "")
            End If
            If ActiveWorkbook.Sheets("import_excel").Range("C23").Value = True Then
                Cells(intRow, intCol).Value = Replace(strTxt, ",", ".")
            Else
                Cells(intRow, intCol).Value = Replace(strTxt, ",", "")
            End If
        End If
        intRow = intRow + 1
        intCol = 1
        intLineCount = intLineCount + 1
        intTotalLines = intTotalLines + 1
    Loop
    Close
    ActiveWorkbook.Sheets("import_excel").Select
    Application.ScreenUpdating = True
    Range("A11").Value = ""
    MsgBox "Import of " & intTotalLines & " rows in " & ActiveWorkbook.Sheets.Count - 1 & " sheets finished.", vbInformation
    strFileName = Left$(strFile, Len(strFile) - 4)
    strFileName = Mid(strFileName, InStrRev(strFileName, "\", -1) + 1)
    Application.StatusBar = "Please specify a path and a filename to save."
    Application.Dialogs(xlDialogSaveAs).Show (strFileName)
    Call setGearz
End Sub