将不带标题的特定列中的可见数据复制到新文件，并向新列中的所有单元格添加数字

Question

我有一个包含宏的大型 Microsoft Excel 365 文件 (11MB)。

我需要将某些已过滤的列从工作表复制到另一个文件中。

根据B列和Q列，我过滤了数据。
我需要将不带标题的列中的可见行复制到文件中（txt“表” - 在 Excel 中打开的 txt 文件）0_import.txt（此文件存储在原始文件之外的其他位置），如下所示：

• 将 I 列插入 A 列
• G 列进入 B 列
• 将 T 列分为 C 列和 D 列

我不需要复制整个 I 列和 T 列（它们包含预先生成的数据），只需复制到 G 列结束的行即可。
这意味着如果 G 列中的最后一条记录位于第 616 行，我需要将 I 列和 T 列的数据复制到第 616 行。

我需要将数字 5 添加到 E 列中。

但首先我需要删除整个文件以确保不保留任何旧数据，最后我需要保存文件0_import.txt。

我只有用于复制 G 列中可见单元格的代码。

Sub Copy_to_new_file()
'
' Copy_to_new_file Macro
' Copy only visible rows in columns G, I, T from this file into new file and add no. 5 into last column.
'
' Shortcut key: Ctrl+Shift+S
'
Worksheets("Sheet1").Activate ' Set the worksheet that contains data as active

' Select only visible cells in column G (sadly with header, which I don't want)
Range("G1", Range("G1").End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

' Set the workbook and the worksheet where to copy data
Dim end_file As Workbook
Dim ws_end As Worksheet

Set end_file = Workbooks.Open("C:\Users\user_name\Documents\0_import.txt")

Set ws_end = Worksheets("0_import")

ws_end.Range("B1").Select ' Set column where to copy visible data from column G in original file
ws_end.Paste

' Delete header from new file (because I don't now how to copy column without it)
ws_end.Range("A1:E1").Select  
Selection.EntireRow.Delete

' Save new file
end_file.Save  

End Sub

如何复制我感兴趣的列中的其他可见数据？

Answer 1

这应该可以正常工作。我添加了一些评论，但如果您有更多问题，请随时提问。这会将 txt 文件保存到“C:\Users\\Documents”

Private Sub copyToFile()
    Dim x As Integer
    
    ' Set the worksheet that contains your data as active
    Worksheets("Sheet1").Activate
    
    'Create two dimensional array (a table) to contain the data you want to copy
    Dim dataToCopy() As String
    ReDim dataToCopy(2, 0)
    
    ' Set numrows = number of rows of data in column G
    NumRows = Range("G1", Range("G1").End(xlDown)).Rows.Count
    
    ' Establish "For" loop to loop "numrows" number of times
    For x = 1 To NumRows
        ' Filter row by columns B and Q to be extracted
        If Range("B" & x).Value = "def" And Range("Q" & x).Value = "" Then
            ' Resize the array since you found an additional row you want to copy
            ReDim Preserve dataToCopy(2, UBound(dataToCopy, 2) - LBound(dataToCopy, 1) + 1)
            ' Copy column I
            dataToCopy(0, UBound(dataToCopy, 2)) = Range("I" & x).Value
            ' Copy column G
            dataToCopy(1, UBound(dataToCopy, 2)) = Range("G" & x).Value
            ' Copy column T
            dataToCopy(2, UBound(dataToCopy, 2)) = Range("T" & x).Value
        End If
    Next
    
    ' Create a file handle and define path where to save the txt file
    Dim handle As Long
    handle = FreeFile
    Open Application.DefaultFilePath & "\Whatever.txt" For Output As #handle
    
    For y = 1 To UBound(dataToCopy, 2)
        Print #handle, dataToCopy(0, y) & "," & dataToCopy(1, y) & "," & dataToCopy(2, y) & "," & dataToCopy(2, y) & "," & "5"
    Next
    
    Close #handle
End Sub

Answer 2

我终于能够编写按我需要的方式工作的代码。

Option Explicit

Sub CopyOnlyVisibleRowsInColumnsG_I_T()
'
' CopyOnlyVisibleRowsInColumnsG_I_T Macro
' Copy only visible rows in columns G, I, T into new file and add no. 5 into last column.
'
' Shortcut key: Ctrl+Shift+I
'
    Dim startWs As Worksheet
    Dim endFile As Workbook
    Dim endWs As Worksheet
    Dim lastRowColB As Long
    Dim lastRowColG As Long
    
    Set startWs = ThisWorkbook.Worksheets("Sheet1")
    
    Set endFile = Workbooks.Open("C:\Users\user_name\OneDrive\Documents\0_import.txt")
    
    Set endWs = Worksheets("0_import")
    
    'clear all content in target workbook
    Cells.ClearContents
    
    'set last row in column G 
    lastRowColG = startWs.Cells(Rows.Count, "G").End(xlUp).Row
    
    startWs.Range("G1:G" & lastRowColG).SpecialCells(xlCellTypeVisible).Copy Destination:=endWs.Range("B:B")
    startWs.Range("I1:I" & lastRowColG).SpecialCells(xlCellTypeVisible).Copy Destination:=endWs.Range("A:A")
    startWs.Range("T1:T" & lastRowColG).SpecialCells(xlCellTypeVisible).Copy Destination:=endWs.Range("C:C")
    startWs.Range("T1:T" & lastRowColG).SpecialCells(xlCellTypeVisible).Copy Destination:=endWs.Range("D:D")
    
    'convert text format to date format for columns C and D
    endWs.Range("C:C, D:D").NumberFormat = "dd.mm.yyyy"

    'delete header from new worksheet
    endWs.Range("A1:E1").Select
    Selection.EntireRow.Delete
    
    'adds 5 to column E according to the number of rows in column B
    lastRowColB = Cells(Rows.Count, "B").End(xlUp).Row
    Range("E1:E" & lastRowColB).Value = 5
    
    'save new file
    endFile.Save
End Sub

唯一不起作用的是键盘快捷键，但这是针对新查询的。