复制/粘贴可见（过滤）单元格到文本（.txt）文件
我已经看遍了所有的论坛，找不到具体的代码来做到这一点（只有可能放在一起的代码片段会做我想做的）。
是否有可能做到以下几点：
- 过滤B列“R / R”
- 复制表单P列中的可见单元格（“Test1”） – 此表单从外部访问查询中提取数据并设置为表格（不确定是否重要）
- 按原样粘贴到特定目的地的文本文件中（按照我的意思是，如果手动复制并将单元格区域粘贴到文本文件中，看起来如何）
我想用“写入”或“打印”来做到这一点，而不是简单地复制到剪贴板并粘贴。
请参阅下面的代码。 它过滤并复制/粘贴到所需的文本文件，但它停止在第一个过滤的单元格，即在列B（571,4213,4510,5191,5192）中有5行具有“R / R”，但它只粘贴细胞P571。
Sub 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
你必须遍历你的范围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