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