Question

我试图让2个For循环同时递增，但我只能将它转到一个循环递增的位置，并且在该循环完成循环之后然后第二个循环递增。我希望代码能够在两个循环的列表中同时进行：

将criteria1（1）和criteria2（1）设置为rngstart和rngend 然后运行For i =（rngStart.Row + 2）To（rngEnd.Row - 3）部分并输出到文本文件

然后将criteria1（2）和criteria2（2）设置为rngstart和rngend 然后运行For i =（rngStart.Row + 2）To（rngEnd.Row - 3）部分并输出到文本文件

等

非常感谢任何关于我做错事以及如何解决问题的指导。

以下是我尝试解决此问题的代码：

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

好的，我在代码中做了一些修改。我应该工作，但我没有测试它。试一试。

请注意，我将原始程序拆分为三个较小的程序。通常，如果您在顶部有大量变量，则表明该过程太大。

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

我希望这会有所帮助：）

如何让2个循环同时递增？

1 个答案: