Sub blah()
Set Destn = Sheets("Sheet2").Range("A10")
fpath = Application.GetOpenFilename("Text Files (*.txt),*.txt")
If Not fpath = False Then
zzz = CreateObject("scripting.filesystemobject").opentextfile(fpath).readall
'zzz = CreateObject("scripting.filesystemobject").opentextfile("C:\Users\mmmmmm\AppData\Local\Temp\data.txt").readall
yyy = Split(zzz, vbCrLf & vbCrLf & "25")
For Each rcd In yyy
If InStr(rcd, "Marks & Numbers") > 0 Then
'Stop
*** = Split(rcd, vbCrLf & vbCrLf)
For i = LBound(***) To UBound(***)
Select Case True
Case InStr(***(i), "Number and Kind") > 0
www = ShortArray(Split(***(i + 1), " "))
B = www(0)
Case InStr(***(i), "34 FOB Ncy") > 0
www = ShortArray(Split(***(i + 1), " "))
L = www(1)
M = Application.Trim(Split(www(2), "|")(0))
N = Application.Trim(Split(www(3), "|")(0))
Case InStr(***(i), "37 Other Costs") > 0
www = ShortArray(Split(***(i + 1), " "))
O = Application.Trim(Split(www(0), "|")(0))
On Error Resume Next
P = www(2)
Q = www(3)
On Error GoTo 0
Case InStr(***(i), "Description of goods") > 0
www = ShortArray(Split(***(i + 1), " "))
C = www(0)
Case InStr(***(i), "31 Gross mass") > 0
www = ShortArray(Split(***(i + 1), " "))
ColmI = www(0)
J = www(1)
K = Application.Trim(Split(www(2), "|")(0))
Case InStr(***(i), "28 Cty. Org") > 0
www = ShortArray(Split(***(i + 1), " "))
F = www(1)
G = www(2)
H = www(3)
Case InStr(***(i), "Marks & Numbers") > 0
www = ShortArray(Split(***(i + 1), " "))
D = www(1)
' Debug.Assert D <> "098"
E = www(2)
Case InStr(***(i), "40 Tax") > 0
www = ShortArray(Split(***(i + 1), " "))
X = www(UBound(www))
'Stop
WriteToSheet Destn, Array(A, B, C, D, E, F, G, H, ColmI, J, K, L, M, N, O, P, Q, , , , , , , X)
ii = i + 1
Do
R = Empty: S = Empty: T = Empty: U = Empty: V = Empty: W = Empty:
ccc = ShortArray(Split(***(ii), " "))
If UBound(ccc) > 2 Then
'Stop
R = ccc(0)
S = ccc(1)
T = ccc(2)
U = ccc(3)
V = ccc(4)
W = ccc(5)
WriteToSheet Destn.Offset(, 17), Array(R, S, T, U, V, W)
Set Destn = Destn.Offset(1)
End If
ii = ii + 1
Loop Until InStr(***(ii), "Total") > 0 Or UBound(ccc) < 3
End Select
'www = Split(thing, " ")
Next i
End If
Next rcd
End If
End Sub
Function ShortArray(myArr)
ReDim NewArr(LBound(myArr) To UBound(myArr))
J = 0
For i = LBound(myArr) To UBound(myArr)
Z = Application.Trim(myArr(i))
If Z <> "" Then
NewArr(J) = Z
J = J + 1
End If
Next i
ReDim Preserve NewArr(LBound(myArr) To J - 1)
ShortArray = NewArr
End Function
Sub WriteToSheet(Dest, myArr)
Dest.Resize(, UBound(myArr) + 1).Value = myArr
End Sub
I note there are instances of