符合条件的内容按要求写入文本

天地一相

感谢帮助！详见截图附件。本求助代码要放入一个循环100次的宏循环代码里，需要在首次宏循环时执行新建打开文本的操作，还需要在第100次宏循环后保存关闭文本。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, r&, strJoin$
   
    ar = Range("H3", Cells(Rows.Count, "H").End(xlUp))
    br = [Q3].CurrentRegion
    For i = 1 To UBound(ar)
        If ar(i, 1) = 4 Then
            r = r + 1
            ar(r, 1) = br(i, 1) & "-" & br(i, 2) & "-" & br(i, 3) & "=" & br(i, 4) & "," & br(i, 5) & "," & br(i, 6) & "/" & br(i, 7)
            strJoin = strJoin & vbCrLf & ar(r, 1)
        End If
    Next i
    If strJoin <> "" Then
         Open ThisWorkbook.Path & "\ " & [H2].Value & ".txt" For Output As #1
             Print #1, Mid(strJoin, 3)
         Close #1
    End If
    Beep
End Sub

天地一相

gwjkkkkk 发表于 2023-6-3 12:23
Option Explicit
Sub TEST1()
    Dim ar, br, i&, r&, strJoin$

谢谢！还没测，先看了一遍代码，貌似没有设置循环初始的语句。如，运行30遍重新开始，第1次运行，新建文本，第30次运行结束，保存关闭文本。然后开始新的30遍运行。在一个30遍循环中，每一遍都会有内容写入文本，不覆盖，接着最后一行写入。我求助时假设5遍循环，我找半天没看到与5相关的句子。可能我猜错了。行号固定到50000.

天地一相

gwjkkkkk 发表于 2023-6-3 12:23
Option Explicit
Sub TEST1()
    Dim ar, br, i&, r&, strJoin$

谢谢，测试了单次的，结果是对的，秒速！没办法处理循环操作的情况。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, r&, strJoin$
   
    ar = Range("H3", Cells(Rows.Count, "H").End(xlUp))
    br = [Q3].CurrentRegion
    For i = 1 To UBound(ar)
        If ar(i, 1) = 4 Then
            r = r + 1
            ar(r, 1) = br(i, 1) & "-" & br(i, 2) & "-" & br(i, 3) & "=" & br(i, 4) & "," & br(i, 5) & "," & br(i, 6) & "/" & br(i, 7)
            strJoin = strJoin & vbCrLf & ar(r, 1)
        End If
    Next i
    If strJoin <> "" Then
         Open ThisWorkbook.Path & "\ " & [H2].Value & ".txt" For Output As #1
             For i = 1 To 5
                  Print #1, Mid(strJoin, 3)
             Next i
         Close #1
    End If
    Beep
End Sub

天地一相

gwjkkkkk 发表于 2023-6-3 12:23
Option Explicit
Sub TEST1()
    Dim ar, br, i&, r&, strJoin$

不对，再仔细检查，单次的保存结果是错的，似乎是出现错行了。谢谢

gwjkkkkk

代码审核中，这样吗？

天地一相

gwjkkkkk 发表于 2023-6-3 12:23
Option Explicit
Sub TEST1()
    Dim ar, br, i&, r&, strJoin$

好像是R列到U列的数据在获取时都有错位，提取的正确位置上放第2个单元格的内容

天地一相

gwjkkkkk 发表于 2023-6-3 17:48
代码审核中，这样吗？

我测试发现有错位情况会不会是因为我实际运行的行数有60000行的原因？谢谢

天地一相

gwjkkkkk 发表于 2023-6-3 17:48
代码审核中，这样吗？

谢谢，还是搞不定。请看看附件，里面有我的想法。