want code import dat convert to vba array

[roykana]

Dear All Master,
I want the code below to be an array vba code because the actual record is 100000 so it makes it very slow


thanks
roykana

Option Explicit
Sub Get_Data_From_File()
    OptimizeVBA True
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim wsSelect As Worksheet
    Dim i As Long
    Dim k As Long
    Dim L As Long
    Dim J As Long
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim objTable As ListObject
    Dim objTable2 As String
    Dim startTime As Single, endTime As Single
    Dim TableFound As Boolean
    startTime = Timer
    Set wsSelect = ActiveWorkbook.Sheets("selectfile")
    With wsSelect
        .Columns("A:G").Clear
        .Range("A1").Value = "ID"
        .Range("B1").Value = "DATE & TIME"
        .Range("C1").Value = "DATE"
        .Range("D1").Value = "YEAR"
        .Range("E1").Value = "PERIOD"
        .Range("F1").Value = "CATEGORY"
        .Range("G1").Value = "NAME"
        .Range("A1:G1").HorizontalAlignment = xlCenter
        LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
    End With
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Dat Files (*.dat*),*dat*", MultiSelect:=True)
    On Error Resume Next
    If IsArray(FileToOpen) Then
        On Error GoTo 0
        For i = LBound(FileToOpen) To UBound(FileToOpen)
            Set OpenBook = Application.Workbooks.Open(FileToOpen(i))
            OpenBook.Sheets(1).Range(Cells(1, 1), Cells(1, 2).End(xlDown)).Copy
            TableFound = TableExists(wsSelect, "TableDat")
            If Not TableFound Then
                wsSelect.Range("A2:B2").PasteSpecial xlPasteValues
                OpenBook.Close False
                wsSelect.Range("A1", "G" & wsSelect.Cells(Rows.Count, "A").End(xlUp).Row).Select
                Set objTable = wsSelect.ListObjects.Add(xlSrcRange, Selection, , xlYes)
                objTable.Name = "TableDat"
            Else
                wsSelect.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                OpenBook.Close False
            End If
        Next
        With wsSelect
            For k = 2 To LastRow
                .Cells(k, 2).Value = WorksheetFunction.Text(.Cells(k, 2).Value, "DD/MM/YYYY HH.MM")
            Next k
            For L = 2 To LastRow
                .Cells(L, 3).Value = DateSerial(Mid(.Cells(L, 2), 7, 4), Mid(.Cells(L, 2), 4, 2), Mid(.Cells(L, 2), 1, 2))
            Next L
             For J = 2 To LastRow
                 .Cells(J, 4).Value = Format(CDate(Cells(J, 2).Text), "YYYY")
            Next J
        End With
    Else
        If FileToOpen = False Then
            On Error GoTo 0
            GoTo getout
        End If
    End If
getout:
    Application.Goto wsSelect.Range("A1")
    endTime = Timer
    Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
    OptimizeVBA False
End Sub
Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub

Function TableExists(ws As Worksheet, sTableName As String) As Boolean
    TableExists = ws.Evaluate("ISREF(" & sTableName & ")")
End Function

 

[roykana]

Not same result on my side, maybe 'cause we do not have the same Windows regional settings or Excel version.​

Anyway try with Value Rather than Value2 …​

And as a demonstration for starters you can add the codeline to create a table​

@Marc L ,

your code is near perfect.

maybe you can help me to create table
I modified your code so that the contents of the dat file don't all go into excel but it doesn't work. the example screenshot below still appears column e to g

Option Explicit

Sub Demo1()
    Dim V, W, F%, X, S, L&, Y, R&
        V = ThisWorkbook.Path & "\test dat file\":  If Dir(V & "*.dat") > "" Then ChDrive V: ChDir V
        W = Application.GetOpenFilename("Text files,*.dat", , "Select files(s)", , True):  If Not IsArray(W) Then Exit Sub
        F = FreeFile
    With Sheets("selectfile")
        ReDim V(1 To .Rows.Count - 1, 1 To 4)
       .UsedRange.Offset(1).Clear
        Application.ScreenUpdating = False
    For Each X In W
        Open X For Input As #F
        S = Split(Input(LOF(F), #F), vbCrLf)
        Close #F
    For L = 0 To UBound(S)
            Y = Split(S(L), vbTab)
        If UBound(Y) = 5 Then
            R = R + 1
            V(R, 1) = Y(0)
            V(R, 2) = Y(1)
            V(R, 3) = Split(Y(1))(0)
            V(R, 4) = Split(Y(1), "-", 2)(0)
'            V(R, 5) = Y(2)
'            V(R, 6) = Y(3)
'            V(R, 7) = Y(4)
        End If
    Next L, X
       .[A2].Resize(R, UBound(V, 2)).Value2 = V
    End With
        Application.ScreenUpdating = True
End Sub

 

[roykana]

@Marc L
Desired Result

Book5
	A	B	C	D	E	F	G
1	ID	DATE & TIME	DATE	YEAR	PERIOD	CATEGORY	NAME
2	5014	27/07/2017 07:42	27/07/2017	2017
selectfile

for column b then the format is general and column B the format is date and the table name is TableDat

 

[roykana]

@Marc L ,

Please also add a comment matrix

 

[BSALV]

???

OpenBook.Sheets(1).Range(Cells(1, 1), Cells(1, 2).End(xlDown))

you opened a file with the columns A:B of the 1st sheet are empty ?
Is it that sheet a worksheet and not a chart ?
Make "worksheets(i)" instead of "sheets(i)" a difference ??

when you debug the code , how does arr() look like after that error ?

 

[BSALV]

add that last line

With ActiveWorkbook.Sheets("selectfile")                   'your sheet
          Application.Goto .Range("A1")
          Set c = .Range("A1").Resize(, 7)                      'headerrow
          c.EntireColumn.Clear
          .columns("C").NumberFormat = "dd/mm/yyyy hh:mm"

 

[johnnyL]

@johnnyL
Dear Mr. johnnyL,

thanks for your reply. Sorry I'm late to reply.
your code has an error "run time error 13" because it can't pass the inappropriate format as I explained in post #13 and your code is still a bit slow and also I didn't test it perfectly because there was an error
Thanks
roykana

@roykana the code I posted runs flawlessly on the dat files you provided as a sample. please try the code on those. perhaps you can supply a link to a different dat file that does produce the error you mentioned?

 

[johnnyL]

@Marc L ,

your code is near perfect.

maybe you can help me to create table

This is your code for the table:

        wsSelect.Range("A1", "G" & wsSelect.Cells(Rows.Count, "A").End(xlUp).Row).Select
        Set objTable = wsSelect.ListObjects.Add(xlSrcRange, Selection, , xlYes)             ' Create Table
        objTable.Name = "TableDat"

Put that code right before the last line of code.

 

[Marc L]

@Marc L
Desired Result

This is the result I got with my original procedure but try on your side just replacing Value2 with Value …​

 

[roykana]

@roykana the code I posted runs flawlessly on the dat files you provided as a sample. please try the code on those. perhaps you can supply a link to a different dat file that does produce the error you mentioned?

@johnnyL
Dear Mr. JohnnyL
link sample file update
Thank you for your reply, I send you a sample link file dat update so you know the error problem of the contents of the dat file
Thanks
roykana

 

[roykana]

This is the result I got with my original procedure but try on your side just replacing Value2 with Value …​

@Marc L
I use it on a different computer so I keep using "value2"