Re: Create Summary and Report from text file
See if this is how you wanted.
Option Explicit
Sub myReport()
Dim fn As String, txt, m, n As Long, temp, a(), x, myArea
fn = Application.GetOpenFilename("TextFiles,*.txt")
If fn = "False" Then Exit Sub
n = 1: ReDim a(1 To 1): a(n) = Array("Area", "Records", "Amunt"):
txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
temp = txt
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True: .IgnoreCase = True
.Pattern = "^\| *Location (Code|Total) *: *(?:[^:]+:)? *(\d+) *\|? *(\S.*\d+|[\d,\.]+) *.*$"
For Each m In .Execute(txt)
Set x = m.submatches
If x(0) = "Code" Then
n = n + 1
ReDim Preserve a(1 To n)
myArea = x(2)
Else
a(n) = Array(myArea, x(1), Replace(x(2), ",", ""))
End If
Next
End With
With Sheets("summary").[a1].Resize(n, 3)
.CurrentRegion.ClearContents
.Value = Application.Index(a, 0, 0)
.Rows(.Rows.Count + 1).Range("b1:c1").Formula = "=sum(r2c:r[-1]c)"
.Columns(3).Resize(n + 1).NumberFormat = "#.00"
.Columns.AutoFit
End With
myQuery temp
End Sub
Private Sub myQuery(ByVal txt As String)
Dim fn As String, a(), x, y, i As Long, ii As Long, maxCol As Long
txt = Mid$(txt, InStr(txt, "|"))
With CreateObject("VBScript.RegExp")
.Global = True: .MultiLine = True: .IgnoreCase = True
.Pattern = "^\|[=-]+\|[\r\n]+|^\| *(?=Location *)"
txt = .Replace(txt, "")
.Pattern = "Location"
txt = Mid$(txt, .Execute(txt)(0).firstindex + 1)
End With
x = Split(txt, vbCrLf): ReDim a(1 To UBound(x) + 1, 1 To 100)
For i = 0 To UBound(x)
x(i) = LTrim$(RTrim$(x(i)))
If x(i) <> "" Then
y = Split(x(i), "|")
maxCol = Application.Max(maxCol, UBound(y) + 1)
If UBound(a, 2) < maxCol Then
ReDim Preserve a(1 To UBound(a, 1), 1 To maxCol)
End If
For ii = 0 To UBound(y)
a(i + 1, ii + 1) = y(ii)
Next
End If
Next
With Sheets("sheet1").[a1].Resize(, maxCol)
.Parent.Cells.ClearContents
.Cells(1).Value = "RUN DATE :" & Date
.Offset(1).Resize(UBound(a, 1)).Value = a
End With
End Sub
Display More