Text file read and replace values, Large file

BalloutMoe

Board Regular
Joined
Jun 4, 2021
Messages
137
Office Version
  1. 365
Platform
  1. Windows
I have the following code that reads the data line by line. I would live to replace the values found by subtracting them by 5. Any help would be appreciated.

The text file is displayed as below. I made the text bold, I am looping through the file and locating "HXX1" in the line and would like to replace the bolded values by subtracting them by 5 in the actual text file and saving it. Any help would be appreciated. Thank you

11QUIK CHEKB 5QAHXX1 0.00 7.00 0.00 0.00 0.00 0.0012571614:33 0 0.00
14QUIK CHEK QUICK CHECK 0.00 N 0 0 0 0
16
11AGJ282 LALXX1 0.00 0.00 0.00 0.00 0.00 0.0012571714:34 2 0.00
14AGJ282 MR 751 0.00 972-- N 0 0 0 0
16
11KPJ235661F 1050NAVXX1 0.00 44.95 1.25 0.00 0.00 0.0012571814:38 3 15.15
14KPJ235661MS 751 18KA 5W20 4.25 3KPFK4A70JE2356610 972-- N 502508 143543 5 0
16
11LN5657939F 1845RABXX1 0.00 59.56 2.36 0.00 0.00 0.0012571914:47 9 28.65
14LN5657939MS 751 05LN 10W30 6.50 1LNHM87A25Y6579391430713 972-- N 184438 18199 7 0
16
11MJ24787 F 1383NAHXX1 0.00 101.62 4.92 0.00 0.00 0.0012572014:52 9 59.62
14MJ24787 MR 751 11FD SYN 5W20 7.75 1FTFW1CF8BFB157521447386 972-- N 314621 96880 7 0
16
11QUIK CHEKB 5QAHXX1 0.00 7.00 0.00 0.00 0.00 0.0012572114:54 0 0.00
14QUIK CHEK QUICK CHECK 0.00 N 0 0 0 0


VBA Code:
Sub GetFleetData()
  Dim Sh As Worksheet, txtFileName As String, lastR As Long, i As Long, j As Long
  Dim arrTxt, arrSI, arrSI2, arrSI3, SI As Long
  Dim fileopening As Object
  
        
'Checks if its a sunday
If SDAYNAME = "Sunday" Then
MsgBox "The Date entered is a Sunday, the shop is closed! Please enter another Date and Click the button again!"
Exit Sub
End If

'Clear content and Set WorksheetName
Set Sh = ThisWorkbook.Worksheets("Sheet2")
 Sh.Range("B2:F50").ClearContents
                  
                    'FileName
                    txtFileName = Sh.Range("P2")
                    'StoreID and Date Combined
             
                    todaysdate = ThisWorkbook.Worksheets("Sheet2").Range("A1").Value 'Date
                    SDAYNAME = Format(todaysdate, "dddd") 'Reformat Date
                    todaysdate2 = Sh.Range("O2").Value & Format(todaysdate, "mmddyy")

  'Array and open Textfile
   Dim fso As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fileopening = fso.OpenTextFile(txtFileName, 1)
arrTxt = Split(fileopening.ReadAll, vbCrLf)
     
  For i = 0 To UBound(arrTxt)
  
      If InStr(arrTxt(i), todaysdate2) > 0 Then
 
         Do While InStr(arrTxt(i + j), "END OF DAY") = 0
            j = j + 1
                                If InStr(arrTxt(i + j), "HXX1") > 0 Then
                                    arrSI = Split(WorksheetFunction.Trim(arrTxt(i + j)), " ")
                                    
                                    If InStr(arrSI(0), "QUIK") > 0 Then
                                    InvoiceTotal = arrSI(4) [B]' this total I would like to replace by arrSI(4) - 5 in the text file it self[/B]
                                                                    
                                    Else
                                   InvoiceTotal = arrSI(3) [B]' this total I would like to replace by arrSI(3) - 5 in the text file it self[/B]
                                                                                                     
                                   End If
                                
                                End If
            
         Loop 'For Do
      End If 'If Instr
  Next i

fileopening.Close
Set fso = Nothing
Set fileopening = Nothing
End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
The problem I am having is there is a lot of spaces between each column in the text file
 
Upvote 0

here is a link to a sample text file where you can see how it is formatted. It needs to stay in the same format
 
Upvote 0
I have gotten here so far but now stuck on how to copy the array into one line including the blanks so it keeps the format and writing it to the text file.

VBA Code:
Sub FindLines()
'Declare ALL of your variables :)
Const ForReading = 1    '
Const fileToRead As String = "C:\Users\axela\Desktop\TEMP.DAT"  ' the path of the file to read
Const fileToWrite As String = "C:\Users\axela\Desktop\TEMPADJUSTED.DAT"  ' the path of a new file
Dim FSO As Object
Dim readFile As Object  'the file you will READ
Dim writeFile As Object 'the file you will CREATE
Dim repLine As Variant   'the array of lines you will WRITE
Dim ln As Variant
Dim l As Long, NewArray As Variant

Set FSO = CreateObject("Scripting.FileSystemObject")
Set readFile = FSO.OpenTextFile(fileToRead, ForReading, False)
Set writeFile = FSO.CreateTextFile(fileToWrite, True, False)

'# Read entire file into an array & close it
repLine = Split(readFile.ReadAll, vbNewLine)
readFile.Close
Dim arrSI As Variant
'# iterate the array and do the replacement line by line
  For t = 0 To UBound(repLine)
  '100001032622
  On Error GoTo FinishLine:
      If InStr(repLine(t + j), "100001032622") > 0 Then
                Do While InStr(repLine(t + j), "END OF DAY") = 0
                    j = j + 1
                                If InStr(repLine(t + j), "HXX1") > 0 Then
                                    arrSI = Split(repLine(t + j), " ")
                                        
                                            For i = 0 To UBound(arrSI)
                                            
                                                 If IsNumeric(arrSI(i)) Then
                                                    If CDec(arrSI(i)) > "100.00" Then
                                                    arrSI(i) = arrSI(i) - 5
                                                End If
                                                End If
                               
                                            Next
                                
                                End If
                                'repLine(t + j) = NewArray(d)
            Loop
      End If 'If Instr
 
Next
FinishLine:
'# Write to the array items to the file
writeFile.Write Join(repLine, vbNewLine)
writeFile.Close

'# clean up
Set readFile = Nothing
Set writeFile = Nothing
Set FSO = Nothing

End Sub
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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