将可见（过滤）单元格复制/粘贴到文本 (.txt) 文件

Question

我浏览了所有论坛，但找不到具体的代码来做到这一点（只有可能放在一起的代码片段才能满足我的需求）。

是否可以做到以下几点：

• 为“R/R”过滤 B 列
• 在 Sheets("Test1") 的 P 列中复制 Visible 单元格 - 此工作表从外部访问查询中提取数据并设置为表格（不确定这是否重要）李>
• 按原样粘贴到特定目标中的文本文件 （我的意思是，如果您手动将单元格区域复制并粘贴到文本文件中，它会是什么样子）

我想使用 Write 或 Print 执行此操作，而不是简单地复制到剪贴板并粘贴。

请参阅下面的代码。它过滤并复制/粘贴到所需的文本文件，但它在第一个过滤的单元格处停止，即 B 列中有 5 行带有“R/R”的行（571,4213,4510,5191,5192），但它只粘贴单元格 P571。

子 abc()

Sheets("Test1").ListObjects("Table_Query_from_MS_Access_Database").Range. _
    AutoFilter Field:=2, Criteria1:="R/R"

LastRow = Sheets("Test1").Range("P" & Rows.Count).End(xlUp).Row

Dim filename As String, lineText As String
Dim myrng As Range, i, j

filename = "C:\Users\bob\Desktop\output.txt"

Open filename For Output As #1

Set myrng = Sheets("Test1").Range("P2:P" & LastRow).SpecialCells(xlCellTypeVisible)

For i = 1 To myrng.Rows.Count
    For j = 1 To myrng.Columns.Count
        lineText = IIf(j = 1, "", lineText & ",") & myrng.Cells(i, j)
    Next j
    Print #1, lineText
Next i

Close #1

结束子

编辑：用户提供的代码最初有效，但似乎存在错误。 每当在一行中出现“R/R”时（例如，单元格 B122 和 B123），它会使用逗号将单元格 P122 和 P123 中的数据一个接一个地粘贴到文本文件中，而不是将其移动到下一行在我想要的文本文件中。 我希望将其粘贴到如下所示的文本文件中（请忽略破折号“-”，我需要将它们放置以将 # 放在此线程的另一行）：

• 1234564789
• 46546546489
• 134123465465
• 7897897897
• 465465654
• 789789645
• 87978978879
• 465465465

但是，它是这样粘贴的，其中一行带有逗号，并将其放在另一个数字旁边：

• 1234564789
• 46546546489
• 134123465465
• 7897897897
• 465465654, 789789645
• 87978978879
• 465465465

Answer 1

你必须遍历你的范围 Areas 集合

你可以试试这个（注释的）代码：

Option Explicit

Sub main()
    Dim myRng As Range
    Dim arr As Variant

    With Sheets("Test1") '<--| reference relevant sheet
        With .ListObjects("Table_Query_from_MS_Access_Database").Range '<--| reference its relevant Table
            .AutoFilter Field:=2, Criteria1:="R/R" '<--| filter it on its 2nd column (column "B" if table starts from column "A"
            If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then Set myRng = .Offset(1).Resize(.rows.Count - 1).SpecialCells(xlCellTypeVisible) 'set filtered range, if any, 1st row (headers) excluded
        End With
        .AutoFilterMode = False '<--| get rows back visible
    End With

    If Not myRng Is Nothing Then WriteFile "C:\Users\bob\Desktop\output.txt", myRng '<--| write txt file if any filtered Table rows
End Sub


Sub WriteFile(filePath As String, rng As Range)
    Dim i As Long
    Dim area As Range

    On Error GoTo ExitSub '<--| be sure to properly close txt file
    Open filePath For Output As #1

    For Each area In rng.Areas '<--| loop through range 'Areas' collection
        For i = 1 To area.rows.Count '<--| loop through current 'area' rows
            Print #1, Join(Application.Transpose(Application.Transpose(area.rows(i).Value)), ",") '<--|collect current Table row cells into an array and then join its content into a string with comma (",") as separator
        Next i
    Next area

ExitSub:
    Close #1
End Sub

---

仅适用于 P 列：

在 OP 澄清后编辑

Option Explicit

Sub main()
    Dim myRng As Range
    Dim arr As Variant

    With Sheets("Test1") '<--| reference relevant sheet
        With .ListObjects("Table_Query_from_MS_Access_Database").Range '<--| reference its relevant Table
            .AutoFilter Field:=2, Criteria1:="R/R" '<--| filter it on its 2nd column (column "B" if table starts from column "A"
            If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then Set myRng = .Offset(1, 15).Resize(.rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) 'set filtered range, if any, 1st row (headers) excluded
        End With
        .AutoFilterMode = False '<--| get rows back visible
    End With

    If Not myRng Is Nothing Then WriteFile "C:\Users\bob\Desktop\output.txt", myRng '<--| write txt file if any filtered Table rows
End Sub


Sub WriteFile(filePath As String, rng As Range)
    Dim i As Long
    Dim area As Range
    Dim lineText As String

    On Error GoTo ExitSub '<--| be sure to properly close txt file
    Open filePath For Output As #1

    For Each area In rng.Areas '<--| loop through range 'Areas' collection
        For i = 1 To area.rows.Count '<--| loop through current 'area' rows
            lineText = IIf(i = 1, "", lineText & vbCrLf) & area(i, 1).Value
        Next i
        Print #1, lineText
    Next area

ExitSub:
    Close #1
End Sub