Import multi dat files in vba run-time error 13

R

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
Dear All Master,
I want to import multi dat files but there is a "run-time error of 13" and I mark the color red in the code below. Please solution.

VBA Code: 
Option Explicit


Sub Get_Data_From_File()
    OptimizeVBA True
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    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
    startTime = Timer
    
    Application.ScreenUpdating = False
     With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    ActiveSheet.DisplayPageBreaks = False
 
   Range("A1").CurrentRegion.Clear
  
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Dat Files (*.dat*),*dat*", MultiSelect:=True)
[COLOR=rgb(184, 49, 47)]If FileToOpen <> False Then 'this line run-time error 13[/COLOR]
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        OpenBook.Sheets(1).Range(Cells(1, 1), Cells(1, 2).End(xlDown)).Copy
        ThisWorkbook.Worksheets("selectfile").Range("A2:B2").PasteSpecial xlPasteValues
        OpenBook.Close False
Range("A1").CurrentRegion.Select
   Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)
   
   End If
 On Error GoTo getout 'if A1 doesn't belong to any Excel Table, then code will end execution
   If [A1].ListObject <> "" Then
    On Error GoTo 0 'restart Error handler
    objTable2 = [A1].ListObject.Name
   End If
  Application.ScreenUpdating = False
 Application.CutCopyMode = False: [H2].Select
getout:
    Application.ScreenUpdating = True
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With


    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
Thanks
roykana
 
Sort by date Sort by votes
Here's the modification. Note that I removed portion
VBA Code: 
Application.ScreenUpdating = False
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    ActiveSheet.DisplayPageBreaks = False

This is because the OptimizeVBA True is doing the same thing.

Need to select until column G to cover the table until G. Change the
wsSelect.Range("A1", wsSelect.Cells(Rows.Count, "B").End(xlUp)).Select which is range column A and B to become
wsSelect.Range("A1", "G" & wsSelect.Cells(Rows.Count, "A").End(xlUp).Row).Select

VBA Code: 
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
                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
    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
 
Upvote 0

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Zot said:
Here's the modification. Note that I removed portion
VBA Code: 
Application.ScreenUpdating = False
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    ActiveSheet.DisplayPageBreaks = False

This is because the OptimizeVBA True is doing the same thing.

Need to select until column G to cover the table until G. Change the
wsSelect.Range("A1", wsSelect.Cells(Rows.Count, "B").End(xlUp)).Select which is range column A and B to become
wsSelect.Range("A1", "G" & wsSelect.Cells(Rows.Count, "A").End(xlUp).Row).Select

VBA Code: 
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
                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
    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
Click to expand...
@Zot
Dear Mr. Zot,
Thank you for your reply
the code you add is perfect for creating a table up to column G But in column A there is still a blank like below that I mark the color yellow
test.xlsm
ABCDEFG
1IDDATE & TIMEDATEYEARPERIODCATEGORYNAME
2501427/07/2017 07.4227-07-17
3500427/07/2017 07.4327-07-17
4501627/07/2017 07.4527-07-17
5502027/07/2017 07.4627-07-17
6500827/07/2017 07.4827-07-17
7500727/07/2017 17.0527-07-17
8500527/07/2017 17.0627-07-17
9502328/07/2017 07.1328-07-17
10502928/07/2017 07.1328-07-17
11502628/07/2017 07.1628-07-17
12100306/05/2017 17.4706-05-17
13100506/05/2017 17.4806-05-17
14100706/05/2017 17.4806-05-17
15100606/05/2017 17.4806-05-17
16200906/05/2017 17.4806-05-17
1700/01/1900 00.0001-01-00
1800/01/1900 00.0001-01-00
1900/01/1900 00.0001-01-00
2000/01/1900 00.0001-01-00
2100/01/1900 00.0001-01-00
2200/01/1900 00.0001-01-00
2300/01/1900 00.0001-01-00
2400/01/1900 00.0001-01-00
2500/01/1900 00.0001-01-00
2600/01/1900 00.0001-01-00
2700/01/1900 00.0001-01-00
2800/01/1900 00.0001-01-00
2900/01/1900 00.0001-01-00
3000/01/1900 00.0001-01-00
3100/01/1900 00.0001-01-00
3200/01/1900 00.0001-01-00
3300/01/1900 00.0001-01-00
3400/01/1900 00.0001-01-00
3500/01/1900 00.0001-01-00
3600/01/1900 00.0001-01-00
3700/01/1900 00.0001-01-00
3800/01/1900 00.0001-01-00
3900/01/1900 00.0001-01-00
4000/01/1900 00.0001-01-00
4100/01/1900 00.0001-01-00
4200/01/1900 00.0001-01-00
4300/01/1900 00.0001-01-00
4400/01/1900 00.0001-01-00
4500/01/1900 00.0001-01-00
4600/01/1900 00.0001-01-00
selectfile

after I check the blank problem in column A is in the code below whether there is another solution
VBA Code: 
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
 
Upvote 0
I have your 3 sample files. I import all of them. I did not get what you were seeing. I run the program the 2nd time and select the same 3 files and did not see blank column A. I did not see such problem when I run. Your last row was more than 16? Probably because it was referring to different sheet.

Cells(k, 2).Value = WorksheetFunction.Text(Cells(k, 2).Value, "DD/MM/YYYY HH.MM")

When you have statement like above, the Cells(k, 2) will refer to sheet that is active at the time you execute the macro. The is why it is always important to have reference. I did not properly check all your additional line but here is how it should be.
VBA Code: 
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
        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
 
Upvote 0
Solution
Zot said:
I have your 3 sample files. I import all of them. I did not get what you were seeing. I run the program the 2nd time and select the same 3 files and did not see blank column A. I did not see such problem when I run. Your last row was more than 16? Probably because it was referring to different sheet.

Cells(k, 2).Value = WorksheetFunction.Text(Cells(k, 2).Value, "DD/MM/YYYY HH.MM")

When you have statement like above, the Cells(k, 2) will refer to sheet that is active at the time you execute the macro. The is why it is always important to have reference. I did not properly check all your additional line but here is how it should be.
VBA Code: 
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
        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
Click to expand...
@Zot
Dear Mr. Zot,
Thank you very much
I switched to another sheet and it went perfectly there was no blank in column A and also no duplicates if I repeated the import again.
thnks
roykana
 
Upvote 0
roykana said:
@Zot
Dear Mr. Zot,
Thank you very much
I switched to another sheet and it went perfectly there was no blank in column A and also no duplicates if I repeated the import again.
thnks
roykana
Click to expand...
thanks for the update
 
Upvote 0
​
Hi, as a reminder On Error Resume Next is useless here for GetOpenFilename like you can see in this thread :​
​
www.mrexcel.com

want code import dat convert to vba array

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...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Import Data Starting from next empty row
Replies
7
Views
478
Tanne
T
C
  • Solved
User Select PDF import to specific Excel sheet
2 3 4
Replies
31
Views
1K
John_w
J
R
  • Solved
want code import dat convert to vba array
2 3 4
Replies
35
Views
4K
roykana
R
SandsB
  • Question Question
Why does "Step Into" stop after I open my input file?
Replies
4
Views
545
SandsB
SandsB
M
  • Question Question
Power Query with Dynamic Data Source
Replies
4
Views
1K
Alex Blakenburg
A

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top