VBA 宏，用于将不带标题的特定列中的可见数据复制到新文件中定义的列，并将数字添加到新列到所有行

Question

首先，我想对查询的糟糕标题表示歉意，但我想不出更好的方法来描述它。

对于VBA我完全是个新手（基础VBA培训是4天前）。我想到了一个在工作中有用的宏，但我只是不知道如何将“组件”放在一起。我们使用的Excel是Microsoft 365。

我有一个包含宏的大型 Excel 文件（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

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