Option Explicit
Public Sub fstest()
Dim strData As String 'whole file
Dim varLine As Variant 'single line
Dim varLines() As Variant 'line data array
Dim strLine As String 'single line
Dim strLines() As String 'parsed lines
Dim strUniqueLineData As String
Dim dicUniqueData As Object 'with reference you can use New Scripting.Dictionary
Dim oFSO As Object 'with reference you can use New Scripting.FileSystemObject
Dim lngRC As Long
Dim tsThing As Object 'with reference you can use TextStream
Dim strSelectedFolder As String
Dim fileThing As Object 'with reference you can use File
Dim strHeaders() As Variant
Dim lngRow As Long
Dim lngCol As Long
Dim strParsed() As String
Const ForReading As Long = 1 'not required if reference used
Const TristateFalse As Long = 0 'not required if reference used
Set dicUniqueData = CreateObject("Scripting.Dictionary")
Set oFSO = CreateObject("Scripting.FileSystemObject")
strHeaders = Array("DATE", "KG-GROSS", "KG-Tot", "BUY", "Tot BUY", "ORDERS", "Tot.Ord", "SELL", "Tot SELL")
'User picks a folder for the text files
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
lngRC = .Show
If lngRC = 0 Then
MsgBox "User cancelled folder selection. Process stopped.", vbExclamation, "No Folder Selected"
Exit Sub
End If
strSelectedFolder = .SelectedItems(1)
End With
'Iterate through the files in the selected folder, looking for *.txt files
For Each fileThing In oFSO.GetFolder(strSelectedFolder).Files
If LCase(fileThing.Name) Like "*.txt" Then
Application.StatusBar = "Processing " & fileThing.Name
Set tsThing = fileThing.OpenAsTextStream(ForReading, TristateFalse)
strData = tsThing.ReadAll
tsThing.Close
strLines = Split(strData, vbCrLf)
strData = vbNullString
For Each varLine In strLines
strLine = varLine
Do
strLine = Replace(strLine, " ", " ")
Loop Until InStr(1, strLine, " ", vbBinaryCompare) = 0
If strLine Like "##-##-## *" Then
strLine = "20" & strLine
strUniqueLineData = Split(strLine, " ", 2)(1)
If dicUniqueData.Exists(strUniqueLineData) Then
Else
dicUniqueData.Add strUniqueLineData, strLine
End If
End If
Next
End If
Next
'Put unique data in array
ReDim varLines(0 To dicUniqueData.Count, 0 To UBound(strHeaders))
For lngCol = LBound(strHeaders) To UBound(strHeaders)
varLines(0, lngCol) = strHeaders(lngCol)
Next
lngRow = 1
For Each varLine In dicUniqueData
strParsed = Split(dicUniqueData(varLine), " ")
For lngCol = LBound(strHeaders) To UBound(strHeaders)
If lngCol = 0 Then
varLines(lngRow, lngCol) = CDate(strParsed(lngCol)) 'Col A is date
Else
varLines(lngRow, lngCol) = Val(strParsed(lngCol)) 'rest are numeric
End If
Next
lngRow = lngRow + 1
Next
'Push array data to worksheet
Application.ScreenUpdating = False
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(UBound(varLines, 1) + 1, UBound(varLines, 2) + 1)).Value = varLines
Application.ScreenUpdating = True
Application.StatusBar = vbNullString
End Sub
Subscribe to: Post Comments (Atom)
No comments:
Post a Comment