How to get 2 loops to increment at the same time? - vba

Question

I am trying to get 2 For loops to increment at the same time but am only able to get it to where one loop increments and after that loop has gone through its complete loop then the 2nd loop increments. I would like for the code to go down the list of both loops at the same time where it goes:
set criteria1 (1) and criteria2 (1) to the rngstart and rngend
then runs the For i = (rngStart.Row + 2) To (rngEnd.Row - 3) section and outputs to a text file
then set criteria1 (2) and criteria2 (2) to the rngstart and rngend
then runs the For i = (rngStart.Row + 2) To (rngEnd.Row - 3) section and outputs to a text file
etc.
Any guidance on what I am doing wrong and how to resolve the issue would be greatly appreciated.
Below is the code I am trying to resolve the issue with:
Sub ExportStuffToText()
Dim rngFind As Range, rngStart As Range, rngEnd As Range, rngPrint As Range, cell As Range
Dim Criteria1, Criteria2
Dim sTextPath
Dim strCriteria1() As String
Dim strCriteria2() As String
Dim a As Integer, b As Integer, i As Integer, j As Integer
Dim intCriteria1Max As Integer
Dim intCriteria2Max As Integer
Dim FileNum As Integer
Dim str_text As String
Dim sLine As String
Dim sType As String
Set rngFind = Columns("B")
intCriteria1Max = 5
ReDim strCriteria1(1 To intCriteria1Max)
strCriteria1(1) = "Entry1"
strCriteria1(2) = "Entry2"
strCriteria1(3) = "Entry3"
strCriteria1(4) = "Entry4"
strCriteria1(5) = "Entry5"
intCriteria2Max = 5
ReDim strCriteria2(1 To intCriteria2Max)
strCriteria2(1) = "Entry2"
strCriteria2(2) = "Entry3"
strCriteria2(3) = "Entry4"
strCriteria2(4) = "Entry5"
strCriteria2(5) = "Entry6"
For a = 1 To intCriteria1Max
For b = 1 To intCriteria2Max
Criteria1 = strCriteria1(a)
Set rngStart = rngFind.Find(What:=Criteria1, LookIn:=xlValues)
sTextPath = rngStart
Criteria2 = strCriteria2(b)
Set rngEnd = rngFind.Find(What:=Criteria2, LookIn:=xlValues)
If rngStart Is Nothing Then
MsgBox "Criteria1 not found"
Exit Sub
ElseIf rngEnd Is Nothing Then
MsgBox "Criteria2 not found"
Exit Sub
End If
FileNum = FreeFile
str_text = ""
For i = (rngStart.Row + 2) To (rngEnd.Row - 3)
sLine = ""
sType = Sheets![Sheetnamegoeshere].Cells(i, 8).Text
If sType = "somestring" Or sType = "adifferentstring" Then
For j = 1 To 2
If j > 1 Then
sLine = sLine & vbTab
End If
sLine = sLine & Sheets![Sheetnamegoeshere].Cells(i, j).Text
Next j
If Not Len(Trim(Replace(sLine, vbTab, ""))) = 0 Then
If i > 4 Then
str_text = str_text & IIf(str_text = "", "", vbNewLine) & sLine
End If
End If
End If
Next
Open sTextPath For Append As #FileNum
Print #FileNum, str_text
Close #FileNum
str_text = ""
Next b
Next a
End Sub

Answer 1

Ok I made some modifications in the code. I should be working but I did not test it. Give it a try.
Note that I split the original procedure into three smaller ones. Usually if you have a huge amount of variables on the top, it's a sign that the procedure is too large.
Option Explicit
Sub ExportStuffToText()
Dim shToWork As Worksheet
Dim arrCriteria(4, 1) As String
Dim strText As String
Dim rngFind As Range
Dim rngStart As Range
Dim rngEnd As Range
' Add the criterias pairs
arrCriteria(0, 0) = "Entry1"
arrCriteria(0, 1) = "Entry2"
arrCriteria(1, 0) = "Entry2"
arrCriteria(1, 1) = "Entry3"
arrCriteria(2, 0) = "Entry3"
arrCriteria(2, 1) = "Entry4"
arrCriteria(3, 0) = "Entry4"
arrCriteria(3, 1) = "Entry5"
arrCriteria(3, 0) = "Entry5"
arrCriteria(3, 1) = "Entry6"
' Put the name of the sheet here "Sheetnamegoeshere"
Set shToWork = Sheets("Sheetnamegoeshere")
Set rngFind = shToWork.Columns("B")
Dim t As Long
' Loop through my criteria pairs.
For t = LBound(arrCriteria, 1) To UBound(arrCriteria, 1)
'Try to find the values pair.
Set rngStart = rngFind.Find(what:=arrCriteria(t, 0), LookIn:=xlValues)
Set rngEnd = rngFind.Find(what:=arrCriteria(t, 1), LookIn:=xlValues)
If Not rngStart Is Nothing And Not rngEnd Is Nothing Then
' Create the text to append.
strText = GetStringToAppend(rngStart, rngEnd)
'Write to the file
WriteToFile rngStart.Value, strText
Else
' If one or more of the ranges is nothing then
' show a message.
If rngStart Is Nothing Then
MsgBox "Criteria1 not found"
Exit Sub
ElseIf rngEnd Is Nothing Then
MsgBox "Criteria2 not found"
Exit Sub
End If
End If
Next t
End Sub
'Creates a string that will be append to the file.
Function GetStringToAppend(ByRef rStart As Range, _
ByRef rEnd As Range) As String
Dim sh As Worksheet
Dim sLine As String
Dim sType As String
Dim ret As String
Dim i As Long, j As Long
'Grab the sheet from one of the ranges.
Set sh = rStart.Parent
For i = (rStart.Row + 2) To (rEnd.Row - 3)
sType = sh.Cells(i, 8).Text
If sType = "somestring" Or sType = "adifferentstring" Then
For j = 1 To 2
If j > 1 Then
sLine = sLine & vbTab
End If
sLine = sLine & sh.Cells(i, j).Text
Next j
If Not Len(Trim$(Replace(sLine, vbTab, vbNullString))) = 0 Then
If i > 4 Then
ret = ret & IIf(ret = vbNullString, vbNullString, vbNewLine) & sLine
End If
End If
End If
Next
'Return the value
GetStringToAppend = ret
End Function
'Procedure to write to the file.
Sub WriteToFile(ByVal strFilePath As String, _
ByVal strContent As String)
Dim FileNum As Integer
FileNum = FreeFile
Open strFilePath For Append As #FileNum
Print #FileNum, strContent
Close #FileNum
End Sub
I hope this helps :)