Vba to loop on a text file and extract data into excel ( reading text file from vba)

kuldeepsingh25

New Member
Joined
Oct 23, 2018
Messages
1
Hi John_w,

I want to READ the String "TREASURY REFERENCE NUMBER: " when this string found, I want to extract columns, below 14 lines from the string , data in excel.Sample text file , required output in excel sample and the code I am trying is as follows:
TextFile:[CODE---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8----+----9----+----10---+----11---+----12---+----13--
===== NEW PAGE ========
RUN DATE: 02/09/2018 PAGE NO: 1
INVOICE NUMBER - VOUCHER NUMBER CONVERSION REPORT
ADVICE REMITTANCE INVOICE VOUCHER TREASURY BLANKET CURR REMITTANCE
NUMBER DATE NUMBER NUMBER REFERENCE PO NUMBER CODE AMOUNT
--------- ---------- -------------------- ---------------- --------- --------- ---- ----------------
000040181 06/09/2018 92244597 20180605892016 000029122 B663865 GBP
92244598 20180605892017 000029122 B663865 GBP
92244599 20180605892018 000029122 B663865 GBP
92244600 20180605892019 000029122 B663865 GBP
92244601 20180605892021 000029122 B663865 GBP
92244602 20180605892022 000029122 B663865 GBP
92244593 20180605892023 000029122 B663865 GBP
92244594 20180605892024 000029122 B663865 GBP
92244595 20180605892025 000029122 B663865 GBP
92244596 20180605892026 000029122 B663865 GBP
92244590 20180605892027 000029122 B663865 GBP
92244591 20180605892028 000029122 B663865 GBP
92244591 20180605892028 000029122 B663865 GBP
92244592 20180605892029 000029122 B663865 GBP
92244589 20180605892030 000029122 B663865 GBP 49446.43
000040182 05/09/2018 9992221539-1 20180805923649 000029297 B674636A8 USD
9992220423-1 20180805923650 000029297 B674636A8 USD
9992221536-1 20180805923658 000029297 B674636A8 USD
9992221544-1 20180805923664 000029297 B674636A8 USD
9992223597-1 20180805923670 000029297 B674636A8 USD
9992223596-1 20180805923692 000029297 B674636A8 USD
9992223554-1 20180805923698 000029297 B674636A8 USD
9992221577-1 20180805923713 000029297 B674636A8 USD
9992220431-1 20180805924036 000029297 B674636A8 USD
9992221542-1 20180805924045 000029297 B674636A8 USD
9992221530-1 20180805924048 000029297 B674636A8 USD 1264321.00
000040183 05/09/2018 9992223554-1 20180805923698 000029297 B674636A8 GBP 27161.67
000040184 06/09/2018 6479006489 20180605891451 000029110 B8006435 GBP 12000.00
000040185 06/09/2018 1003502 20180605891494 000029154 B8006592B USD 35200.00
1003485 20180605891473 000029154 B8008923B USD
1003485 20180605891473 000029154 B8008923B USD
1003486 20180605891478 000029154 B8008923B USD
1003487 20180605891479 000029154 B8008923B USD
1003488 20180605891480 000029154 B8008923B USD
1003489 20180605891481 000029154 B8008923B USD
1003490 20180605891482 000029154 B8008923B USD
1003491 20180605891483 000029154 B8008923B USD
1003492 20180605891484 000029154 B8008923B USD
1003493 20180605891485 000029154 B8008923B USD
1003494 20180605891486 000029154 B8008923B USD
1003495 20180605891487 000029154 B8008923B USD
1003496 20180605891488 000029154 B8008923B USD
1003497 20180605891489 000029154 B8008923B USD
1003498 20180605891490 000029154 B8008923B USD
1003499 20180605891491 000029154 B8008923B USD
1003500 20180605891492 000029154 B8008923B USD
1003501 20180605891493 000029154 B8008923B USD 468705.00
*** END OF REPORT ***
*** END OF REPORT ***
===== NEW PAGE ========
RUN DATE: 02/09/2018 REMITTANCE ADVICE PAGE 1 OF 1

TREASURY REFERENCE NUMBER: 000029122
REMITTANCE ADVICE NUMBER : 000040181
REMITTANCE DATE: 06/09/2018
CURRENCY: GBP

SUPPLIER CODE: V243
SUPPLIER NAME AND ADDRESS
GUSTAV KLAUKE GMBH
AUF DEM KNAPP 46

REMSCHEID XXX XXX
GERMANY
ORDER POINT:

INV/CR INV/CR BLANKET

INV/CR INV/CR BLANKET
NUMBER DATE PO NUMBER CHARGE TYPE AMOUNT
-------------------- ---------- ---------------- -------------------------- -------------------
92244599 05/06/2018 B663865 NET VALUE 462.80
92244595 05/06/2018 B663865 NET VALUE 16339.18
92244589 05/06/2018 B663865 NET VALUE 1103.60
92244596 05/06/2018 B663865 NET VALUE 10551.32
92244598 05/06/2018 B663865 NET VALUE 213.60
92244591 05/06/2018 B663865 NET VALUE 2456.40
92244593 05/06/2018 B663865 NET VALUE 1778.00
92244590 05/06/2018 B663865 NET VALUE 61.64
92244600 05/06/2018 B663865 NET VALUE 1798.60
92244592 05/06/2018 B663865 NET VALUE 3087.00
92244601 05/06/2018 B663865 NET VALUE 2218.00
92244597 05/06/2018 B663865 NET VALUE 2182.84
92244602 05/06/2018 B663865 NET VALUE 644.93
92244594 05/06/2018 B663865 NET VALUE 6548.52

REMITTANCE AMOUNT (GBP) 49446.43

REMITTANCE AMOUNT (GBP) 49446.43
BT Financial Accounting and Billing
Accounts Payable Centre PO Box 998 Manchester M60 1GT
Freephone 0800 515465
===== NEW PAGE ========
RUN DATE: 02/09/2018 REMITTANCE ADVICE PAGE 1 OF 1

TREASURY REFERENCE NUMBER: 000029297
REMITTANCE ADVICE NUMBER : 000040182
REMITTANCE DATE: 05/09/2018
CURRENCY: USD

SUPPLIER CODE: V473
SUPPLIER NAME AND ADDRESS
CISCO INTERNATIONAL LTD
9-11 NEW SQUARE PARK
BENFONT LAKES
FELTHAM TW14 8HA
FELTHAM TW14 8HA
UNITED KINGDOM
ORDER POINT:

INV/CR INV/CR BLANKET
NUMBER DATE PO NUMBER CHARGE TYPE AMOUNT
-------------------- ---------- ---------------- -------------------------- -------------------
9992221539-1 28/07/2018 B674636A8 NET VALUE 297400.00
9992221577-1 28/07/2018 B674636A8 NET VALUE 45918.00
9992221530-1 28/07/2018 B674636A8 NET VALUE 24600.00
9992221536-1 28/07/2018 B674636A8 NET VALUE 157133.00
9992221544-1 28/07/2018 B674636A8 NET VALUE 104755.00
9992221542-1 28/07/2018 B674636A8 NET VALUE 26298.00
9992223597-1 28/07/2018 B674636A8 NET VALUE 72135.00
9992223596-1 28/07/2018 B674636A8 NET VALUE 57646.00
9992220423-1 28/07/2018 B674636A8 NET VALUE 262440.00
9992223554-1 28/07/2018 B674636A8 NET VALUE 177909.00
9992220431-1 28/07/2018 B674636A8 NET VALUE 38087.00

REMITTANCE AMOUNT (USD) 1264321.00

REMITTANCE AMOUNT (USD) 1264321.00
BT Financial Accounting and Billing
Accounts Payable Centre PO Box 998 Manchester M60 1GT
Freephone 0800 515465
===== NEW PAGE ========
RUN DATE: 02/09/2018 REMITTANCE ADVICE PAGE 1 OF 1

TREASURY REFERENCE NUMBER: 000029297
REMITTANCE ADVICE NUMBER : 000040183
REMITTANCE DATE: 05/09/2018
CURRENCY: GBP

SUPPLIER CODE: V473
SUPPLIER NAME AND ADDRESS
CISCO INTERNATIONAL LTD
9-11 NEW SQUARE PARK
BENFONT LAKES
FELTHAM TW14 8HA
FELTHAM TW14 8HA
UNITED KINGDOM
ORDER POINT:

INV/CR INV/CR BLANKET
NUMBER DATE PO NUMBER CHARGE TYPE AMOUNT
-------------------- ---------- ---------------- -------------------------- -------------------
9992223554-1 28/07/2018 B674636A8 VAT VALUE 27161.67
][/CODE]

OuputExcel File:Code:
TREASURY REFERENCE NUMBERINVOICE_NOINVOICE_DATEPO_NUMBERCHARGE_TYPEAMOUNT
292979992221539-128/07/2018B674636A8NET VALUE297400
292979992221577-128/07/2018B674636A8NET VALUE45918
292979992221530-128/07/2018B674636A8NET VALUE24600
292979992221536-128/07/2018B674636A8NET VALUE157133
292979992221544-128/07/2018B674636A8NET VALUE104755
292979992221542-128/07/2018B674636A8NET VALUE26298
292979992223597-128/07/2018B674636A8NET VALUE72135
292979992223596-128/07/2018B674636A8NET VALUE57646
292979992220423-128/07/2018B674636A8NET VALUE262440
292979992223554-128/07/2018B674636A8NET VALUE177909
292979992220431-128/07/2018B674636A8NET VALUE38087
29154100350223/05/2018B8006592BNET VALUE35200
29154100348523/05/2018B8008923BNET VALUE22420
29154100348623/05/2018B8008923BNET VALUE24440
29154100348723/05/2018B8008923BNET VALUE25810
29154100348823/05/2018B8008923BNET VALUE11800
29154100348923/05/2018B8008923BNET VALUE18800
29154100349023/05/2018B8008923BNET VALUE58003
29154100349123/05/2018B8008923BNET VALUE12750
29154100349223/05/2018B8008923BNET VALUE10740
29154100349323/05/2018B8008923BNET VALUE23826
29154100349423/05/2018B8008923BNET VALUE11400
29154100349523/05/2018B8008923BNET VALUE40554
29154100349623/05/2018B8008923BNET VALUE52320
29154100349723/05/2018B8008923BNET VALUE34010
29154100349823/05/2018B8008923BNET VALUE46280
29154100349823/05/2018B8008923BNET VALUE46280
29154100349923/05/2018B8008923BNET VALUE23664
29154100350023/05/2018B8008923BNET VALUE27876
29154100350123/05/2018B8008923BNET VALUE24012
29320100025970228/08/2018B662055CREDIT NET VALUE-10227.48
29320100025970428/08/2018B662055CREDIT NET VALUE-609.5
29320100025970428/08/2018B662055CREDIT NET VALUE-609.5
29320100025970328/08/2018B662055CREDIT NET VALUE-3816
29320100026180931/08/2018B662055CREDIT NET VALUE-892.5
292989992226374-101/08/2018B674636A8NET VALUE48637

<tbody>

</tbody>


TheCode which I am trying:Code:
Public Sub Import_Text_File()
Dim dataFile As String
Dim fileLine As String, item As String, parts As Variant
Dim i As Long, mRow As Long, n As Long
Dim pprData() As Variant
Dim treasuryrefno As String
Dim pprReportDest As Range

dataFile = "C:\Users\desktop\ALL.txt" 'CHANGE THIS FOLDER PATH AND FILE NAME

With Worksheets("PPR_Consolidated")
.Cells.Clear
.Range("A1:G1").Value = Array("TREASURY_BATCH_NO", "INVOICE_NO", "INVOICE_DATE", "PO_NUMBER", "CHARGE_TYPE", "NET_VALUE", "REMITTANCE_AMT")
Set pprReportDest = .Range("A2")
mRow = 0
End With

Open dataFile For Input As #1
n = 0

While Not EOF(1)

Line Input #1 , fileLine
Debug.Print fileLine

item = GetItem(fileLine, "TREASURY REFERENCE NUMBER: ")
If item <> "" Then treasuryrefno = item

parts = Split(Application.WorksheetFunction.Trim(fileLine), " ")

If UBound(parts) = 4 Then
If IsNumeric(parts(0)) Then
n = n + 1
ReDim Preserve pprData(1 To 7, 1 To n)
pprData(1, n) = treasuryrefno
pprData(2, n) = parts(0)
pprData(3, n) = parts(1)
pprData(4, n) = parts(2)
pprData(5, n) = parts(3)
pprData(6, n) = parts(4)
End If
End If

item = GetItem(fileLine, "REMITTANCE AMOUNT ")
If item <> "" Then

For i = 1 To n
pprData(7, i) = item
Next
pprReportDest.Offset(mRow, 0).Resize(n, UBound(pprData)).Value = Application.Transpose(pprData)
mRow = mRow + n
n = 0
End If

Wend

Close #1

MsgBox "Finished"
End Sub
Private Function GetItem(text As String, item As String) As String
Dim p1 As Long, p2 As Long

GetItem = ""
p1 = InStr(text, item)
If p1 > 0 Then
p1 = p1 + Len(item)
p2 = InStr(p1, text, " ")
If p2 = 0 Then p2 = Len(text) + 1
GetItem = Mid(text, p1, p2 - p1)
'Debug.Print GetItem
End If
End Function

Need your help ugently!

Thanks n advance!
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

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