Need to reset Do while Loop

BalloutMoe

Board Regular
Joined
Jun 4, 2021
Messages
137
Office Version
  1. 365
Platform
  1. Windows
Hello all I have a code that reads through a text file,
I would like to reset the Do Loop after this condition is true If InStr(arrTxt(i), todaysdate) > 0, it runs perfect the first time but then it wont find anything on the next run. Any help how can I reset it the Do to the zero

Thank you

VBA Code:
  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), todaysdate) > 0 Then
      i = i + 2
      If InStr(arrTxt(i), "=MF") Then
                      'If InStr(arrTxt(i + j), "=MF") > 0 Then
        i = i - 1
                        If InStr(arrTxt(i), "ReceiptNumber") > 0 Then
                                InvoiceArray = Split(arrTxt(i), "=")
                                InvoiceNumber = InvoiceArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("B" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("B" & lastR + 1).Resize(1, 1).Value = InvoiceNumber
                        End If
          i = i + 2
                        If InStr(arrTxt(i), "FirstName=") > 0 Then
                                CompanyArray = Split(arrTxt(i), "=")
                                CompanyName = CompanyArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("C" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("C" & lastR + 1).Resize(1, 1).Value = CompanyName
                        End If
                        
        'I Need to reset it to 0 before finding the next   If InStr(arrTxt(i), todaysdate) > 0 Then
        Do While InStr(arrTxt(i + j), "[COMMENTS]") = 0
            j = j + 1
                        'LiscPlate
                        If InStr(arrTxt(i + j), "FleetLicn=") > 0 Then
                                PlateArray = Split(arrTxt(i + j), "=")
                                LiscPlate = PlateArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("E" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("E" & lastR + 1).Resize(1, 1).Value = Trim(LiscPlate)
                        End If

           Loop 
         End If
      End If 'If Instr
  Next i
 
Please try this now

VBA Code:
Option Explicit

'~~> Change this to your file name
Private Const txtFile As String = "C:\Users\routs\Desktop\test.Txt"

Dim strData() As String
Dim rw As Long
Dim ws As Worksheet

Sub Sample()
    Dim MyData As String
   
    '~~> This will add a new worksheet for output
    Set ws = ThisWorkbook.Sheets.Add
   
    '~~> Add headers to new worksheet
    With ws
        .Cells(1, 1).Value = "FirstName"
        .Cells(1, 2).Value = "Vin"
        .Cells(1, 3).Value = "Year"
        .Cells(1, 4).Value = "Make"
        .Cells(1, 5).Value = "Model"
        .Cells(1, 6).Value = "Total"
        .Cells(1, 7).Value = "FleetLicn"
    End With
   
    '~~> This is the 2nd row in the new sheet from where
    '~~> the data will be added
    rw = 2
   
    '~~> Open the text file
    Open txtFile For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)
     
    '~~> Start position and End position variables
    Dim sPos As Long, ePos As Long
    Dim i As Long, j As Long
    Dim todaysdate As String
   
    '~~> I am taking this sample date for testing
    todaysdate = "03/29/2022"
       
    '~~> Loop though the array
    For i = LBound(strData) To UBound(strData)
        '~~> Find [CUST] and then find the following [COMMENTS]
        '~~> This will give use the block between [CUST]...[COMMENTS]
        If InStr(1, strData(i), "[CUST]", vbTextCompare) Then
            sPos = i
           
            For j = sPos To UBound(strData)
                If InStr(1, strData(j), "[COMMENTS]", vbTextCompare) Then
                    ePos = j
                    Exit For
                End If
            Next j
        End If
       
        If ePos <> 0 Then
            If IsConditionMet("RecDateTime", todaysdate, sPos, ePos) Then
                If IsConditionMet("Mrs", "=MF", sPos, ePos) Then
                    '~~> Extract data
                    With ws
                        .Cells(rw, 1).Value = GetItemValue("FirstName", sPos, ePos)
                        .Cells(rw, 2).Value = GetItemValue("Vin=", sPos, ePos)
                        .Cells(rw, 3).Value = GetItemValue("Year", sPos, ePos)
                        .Cells(rw, 4).Value = GetItemValue("Make", sPos, ePos)
                        .Cells(rw, 5).Value = GetItemValue("Model", sPos, ePos)
                        .Cells(rw, 6).Value = GetItemValue("Total", sPos, ePos)
                        .Cells(rw, 7).Value = GetItemValue("FleetLicn", sPos, ePos)
                        rw = rw + 1
                    End With
                End If
            End If
            
            '~~> Set new starting position
            sPos = ePos + 1:  i = sPos: ePos = 0
        End If
    Next i
End Sub

'~~> Function to check if condition is met
Private Function IsConditionMet(itmHeader As String, itmValue As String, StartPos As Long, EndPos As Long) As Boolean
    Dim k As Long
    
    For k = StartPos To EndPos
        If InStr(1, strData(k), itmHeader, vbTextCompare) Then
            If InStr(1, strData(k), itmValue) Then
                IsConditionMet = True
                Exit For
            End If
        End If
    Next k
End Function

'~~> Retrieve the values
Private Function GetItemValue(itmHeader As String, StartPos As Long, EndPos As Long) As Variant
    Dim k As Long
    Dim retVal As Variant
    
    For k = StartPos To EndPos
        If InStr(1, strData(k), itmHeader, vbTextCompare) Then
            retVal = Split(strData(k), "=")(1)
            Exit For
        End If
    Next k
    GetItemValue = retVal
End Function
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Please try this now

VBA Code:
Option Explicit

'~~> Change this to your file name
Private Const txtFile As String = "C:\Users\routs\Desktop\test.Txt"

Dim strData() As String
Dim rw As Long
Dim ws As Worksheet

Sub Sample()
    Dim MyData As String
  
    '~~> This will add a new worksheet for output
    Set ws = ThisWorkbook.Sheets.Add
  
    '~~> Add headers to new worksheet
    With ws
        .Cells(1, 1).Value = "FirstName"
        .Cells(1, 2).Value = "Vin"
        .Cells(1, 3).Value = "Year"
        .Cells(1, 4).Value = "Make"
        .Cells(1, 5).Value = "Model"
        .Cells(1, 6).Value = "Total"
        .Cells(1, 7).Value = "FleetLicn"
    End With
  
    '~~> This is the 2nd row in the new sheet from where
    '~~> the data will be added
    rw = 2
  
    '~~> Open the text file
    Open txtFile For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)
    
    '~~> Start position and End position variables
    Dim sPos As Long, ePos As Long
    Dim i As Long, j As Long
    Dim todaysdate As String
  
    '~~> I am taking this sample date for testing
    todaysdate = "03/29/2022"
      
    '~~> Loop though the array
    For i = LBound(strData) To UBound(strData)
        '~~> Find [CUST] and then find the following [COMMENTS]
        '~~> This will give use the block between [CUST]...[COMMENTS]
        If InStr(1, strData(i), "[CUST]", vbTextCompare) Then
            sPos = i
          
            For j = sPos To UBound(strData)
                If InStr(1, strData(j), "[COMMENTS]", vbTextCompare) Then
                    ePos = j
                    Exit For
                End If
            Next j
        End If
      
        If ePos <> 0 Then
            If IsConditionMet("RecDateTime", todaysdate, sPos, ePos) Then
                If IsConditionMet("Mrs", "=MF", sPos, ePos) Then
                    '~~> Extract data
                    With ws
                        .Cells(rw, 1).Value = GetItemValue("FirstName", sPos, ePos)
                        .Cells(rw, 2).Value = GetItemValue("Vin=", sPos, ePos)
                        .Cells(rw, 3).Value = GetItemValue("Year", sPos, ePos)
                        .Cells(rw, 4).Value = GetItemValue("Make", sPos, ePos)
                        .Cells(rw, 5).Value = GetItemValue("Model", sPos, ePos)
                        .Cells(rw, 6).Value = GetItemValue("Total", sPos, ePos)
                        .Cells(rw, 7).Value = GetItemValue("FleetLicn", sPos, ePos)
                        rw = rw + 1
                    End With
                End If
            End If
           
            '~~> Set new starting position
            sPos = ePos + 1:  i = sPos: ePos = 0
        End If
    Next i
End Sub

'~~> Function to check if condition is met
Private Function IsConditionMet(itmHeader As String, itmValue As String, StartPos As Long, EndPos As Long) As Boolean
    Dim k As Long
   
    For k = StartPos To EndPos
        If InStr(1, strData(k), itmHeader, vbTextCompare) Then
            If InStr(1, strData(k), itmValue) Then
                IsConditionMet = True
                Exit For
            End If
        End If
    Next k
End Function

'~~> Retrieve the values
Private Function GetItemValue(itmHeader As String, StartPos As Long, EndPos As Long) As Variant
    Dim k As Long
    Dim retVal As Variant
   
    For k = StartPos To EndPos
        If InStr(1, strData(k), itmHeader, vbTextCompare) Then
            retVal = Split(strData(k), "=")(1)
            Exit For
        End If
    Next k
    GetItemValue = retVal
End Function
Thank you for your code however it is picking up wrong totals and for some reason not a MF below is my code and so far it has been working and it was a bit quicker. I added j to 48 which is not ideal for me but I have no idea of a work arround


VBA Code:
Sub GetRecieptsFile()
  Dim Sh As Worksheet, txtFileName As String, lastR As Long, i As Long, j As Long
  Dim arrTxt, arrSI, InvoiceArray, 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:J50").ClearContents
                  
                    'FileName
                    txtFileName = Sh.Range("T1")
                    'StoreID and Date Combined
             
                    todaysdate = Format(ThisWorkbook.Worksheets("Sheet2").Range("A1").Value, "mm/dd/yyyy") 'Date
                    Debug.Print todaysdate
                    'SDAYNAME = Format(todaysdate, "mm/") 'Reformat Date
                    

'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)
  'On Error Resume Next
      If InStr(arrTxt(i), todaysdate) > 0 Then
      
      i = i + 2
      If InStr(arrTxt(i), "=MF") Then
                      'If InStr(arrTxt(i + j), "=MF") > 0 Then
        i = i - 1
                        If InStr(arrTxt(i), "ReceiptNumber") > 0 Then
                                InvoiceArray = Split(arrTxt(i), "=")
                                InvoiceNumber = InvoiceArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("B" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("B" & lastR + 1).Resize(1, 1).Value = InvoiceNumber
                                ThisWorkbook.Worksheets("Sheet2").Range("F" & lastR + 1).Resize(1, 1).Value = todaysdate
                                
                        End If
          i = i + 2
                        If InStr(arrTxt(i), "FirstName=") > 0 Then
                                CompanyArray = Split(arrTxt(i), "=")
                                CompanyName = CompanyArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("C" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("C" & lastR + 1).Resize(1, 1).Value = CompanyName
                        End If

                        'CompanyName
            Do Until j = 48
            j = j + 1
                        'LiscPlate
                        If InStr(arrTxt(i + j), "FleetLicn=") > 0 Then
                                PlateArray = Split(arrTxt(i + j), "=")
                                LiscPlate = PlateArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("E" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("E" & lastR + 1).Resize(1, 1).Value = Trim(Replace(LiscPlate, " ", ""))
                        End If
                                  
                        If Left(arrTxt(i + j), 4) = "VIN=" Then
                                VinArray = Split(arrTxt(i + j), "=")
                                VinNumber = VinArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("G" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("G" & lastR + 1).Resize(1, 1).Value = Trim(Right(VinNumber, 8))
                        End If
                        
                        If InStr(arrTxt(i + j), "Year=") > 0 Then
                                YearArray = Split(arrTxt(i + j), "=")
                                VehicleYear = YearArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("H" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("H" & lastR + 1).Resize(1, 1).Value = Trim(VehicleYear)
                        End If
                                  
                        If InStr(arrTxt(i + j), "Make=") > 0 Then
                                MakeArray = Split(arrTxt(i + j), "=")
                                VehicleMake = MakeArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("I" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("I" & lastR + 1).Resize(1, 1).Value = Trim(VehicleMake)
                        End If
                
                        If InStr(arrTxt(i + j), "Model=") > 0 Then
                                ModelArray = Split(arrTxt(i + j), "=")
                                VehicleModel = ModelArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("J" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("J" & lastR + 1).Resize(1, 1).Value = Trim(VehicleModel)
                        End If
                        
                        If Left(arrTxt(i + j), 6) = "Total=" Then
                                TotalArray = Split(arrTxt(i + j), "=")
                                InvoiceTotal = TotalArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("D" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("D" & lastR + 1).Resize(1, 1).Value = FormatCurrency(Trim(InvoiceTotal))
                        End If
                'End If 'MF
            Loop 'Until InStr(arrTxt(i + j), "[COMMENTS]") = 1 'For Do
         End If
       
      End If 'If Instr
  j = 0
  Next i

fileopening.Close
Set fso = Nothing
Set fileopening = Nothing
End Sub
 
Upvote 0
Thank you for your code however it is picking up wrong totals and for some reason not a MF below is my code and so far it has been working and it was a bit quicker. I added j to 48 which is not ideal for me but I have no idea of a work arround

Can you be more specific please? Are you only getting a wrong total? Is everything else fine? Whatever you feel is not right, please mention in detail with an example.
 
Upvote 0
Can you be more specific please? Are you only getting a wrong total? Is everything else fine? Whatever you feel is not right, please mention in detail with an example.
Sorry about the late reply, I was out of town. I attached link to a sample file of how usually each receipt is broken down. Here is the link

 
Upvote 0
Any Help
Thank you for your code however it is picking up wrong totals and for some reason not a MF below is my code and so far it has been working and it was a bit quicker. I added j to 48 which is not ideal for me but I have no idea of a work arround


VBA Code:
Sub GetRecieptsFile()
  Dim Sh As Worksheet, txtFileName As String, lastR As Long, i As Long, j As Long
  Dim arrTxt, arrSI, InvoiceArray, 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:J50").ClearContents
                 
                    'FileName
                    txtFileName = Sh.Range("T1")
                    'StoreID and Date Combined
            
                    todaysdate = Format(ThisWorkbook.Worksheets("Sheet2").Range("A1").Value, "mm/dd/yyyy") 'Date
                    Debug.Print todaysdate
                    'SDAYNAME = Format(todaysdate, "mm/") 'Reformat Date
                   

'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)
  'On Error Resume Next
      If InStr(arrTxt(i), todaysdate) > 0 Then
     
      i = i + 2
      If InStr(arrTxt(i), "=MF") Then
                      'If InStr(arrTxt(i + j), "=MF") > 0 Then
        i = i - 1
                        If InStr(arrTxt(i), "ReceiptNumber") > 0 Then
                                InvoiceArray = Split(arrTxt(i), "=")
                                InvoiceNumber = InvoiceArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("B" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("B" & lastR + 1).Resize(1, 1).Value = InvoiceNumber
                                ThisWorkbook.Worksheets("Sheet2").Range("F" & lastR + 1).Resize(1, 1).Value = todaysdate
                               
                        End If
          i = i + 2
                        If InStr(arrTxt(i), "FirstName=") > 0 Then
                                CompanyArray = Split(arrTxt(i), "=")
                                CompanyName = CompanyArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("C" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("C" & lastR + 1).Resize(1, 1).Value = CompanyName
                        End If

                        'CompanyName
            Do Until j = 48
            j = j + 1
                        'LiscPlate
                        If InStr(arrTxt(i + j), "FleetLicn=") > 0 Then
                                PlateArray = Split(arrTxt(i + j), "=")
                                LiscPlate = PlateArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("E" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("E" & lastR + 1).Resize(1, 1).Value = Trim(Replace(LiscPlate, " ", ""))
                        End If
                                 
                        If Left(arrTxt(i + j), 4) = "VIN=" Then
                                VinArray = Split(arrTxt(i + j), "=")
                                VinNumber = VinArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("G" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("G" & lastR + 1).Resize(1, 1).Value = Trim(Right(VinNumber, 8))
                        End If
                       
                        If InStr(arrTxt(i + j), "Year=") > 0 Then
                                YearArray = Split(arrTxt(i + j), "=")
                                VehicleYear = YearArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("H" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("H" & lastR + 1).Resize(1, 1).Value = Trim(VehicleYear)
                        End If
                                 
                        If InStr(arrTxt(i + j), "Make=") > 0 Then
                                MakeArray = Split(arrTxt(i + j), "=")
                                VehicleMake = MakeArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("I" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("I" & lastR + 1).Resize(1, 1).Value = Trim(VehicleMake)
                        End If
               
                        If InStr(arrTxt(i + j), "Model=") > 0 Then
                                ModelArray = Split(arrTxt(i + j), "=")
                                VehicleModel = ModelArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("J" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("J" & lastR + 1).Resize(1, 1).Value = Trim(VehicleModel)
                        End If
                       
                        If Left(arrTxt(i + j), 6) = "Total=" Then
                                TotalArray = Split(arrTxt(i + j), "=")
                                InvoiceTotal = TotalArray(1)
                                lastR = ThisWorkbook.Worksheets("Sheet2").Range("D" & Sh.Rows.Count).End(xlUp).Row
                                ThisWorkbook.Worksheets("Sheet2").Range("D" & lastR + 1).Resize(1, 1).Value = FormatCurrency(Trim(InvoiceTotal))
                        End If
                'End If 'MF
            Loop 'Until InStr(arrTxt(i + j), "[COMMENTS]") = 1 'For Do
         End If
      
      End If 'If Instr
  j = 0
  Next i

fileopening.Close
Set fso = Nothing
Set fileopening = Nothing
End Sub
Any Help please
 
Upvote 0

Forum statistics

Threads
1,214,388
Messages
6,119,226
Members
448,878
Latest member
Da9l87

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