excel - 使用 VBA 将特定列从工作簿复制到另一个

Question

我需要帮助编写一个可以 的宏根据用户输入将数据从一个工作簿复制并粘贴到新工作簿 .也就是说，宏应该做 3 件事:

允许用户选择包含要复制到新工作簿中的数据的工作簿。

提示用户选择要复制到新工作簿中的数据列，最好仅按列标题。

提示用户保存文件。

下面的代码允许用户选择工作簿并将打开的工作簿中的数据范围放入用户表单，但我不知道如何将所选数据从该用户窗体复制到新工作簿 .该代码还按行显示工作簿中的数据，但 我只想要列标题列表 .
注: “multiColumnRange”是数据范围的定义名称，但这是我希望动态的“硬编码”。也就是说，数据范围会因工作簿而异。

Sub Select_Workbook()

'Disables screen updating
Application.ScreenUpdating = False

'Defines the variable to hold the value of the file to open
Dim FileToOpen As Variant
'Defines the variable of the location of the file and the new workbook
Dim OpenBook As Workbook, NewBook As Workbook
     
Dim strCol As String

'Defines variable to hold value of table range
Dim rngMultiColumn As Range

 'Sets the variable to the file that is selected
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
'Checks if the user selected cancel and stores the Boolean value and not string
    If FileToOpen <> False Then
    Set OpenBook = Workbooks.Open(FileToOpen)
    
    'Define source range, referring to table's data range
    Set rngMultiColumn = OpenBook.Worksheets("Export").Range("multiColumnRange")
    
    With ufrmListBoxMultiColumn.lboxExampleMC
        .ColumnWidths = "120;120;120"
        .List = rngMultiColumn.Cells.Value
    End With
    
    ufrmListBoxMultiColumn.Show
    
    'Creates new workbook and assigns it to variable NewBook
    Set NewBook = Workbooks.Add

    End sub

Answer 1

试试看

Sub move_data()

Dim data_wb As Workbook
Dim target_wb As Workbook
Dim file_name As Variant
Dim header_range(100) As Range
Dim last_row As Long
Dim col_number As Long
Dim col_letter As String
Dim counter As Long
Dim quantity As Long

'select workbook
file_name = Application.GetOpenFilename(Title:="Choose a target Workbook")

If file_name <> False Then

    'create a new target workbook
    Set target_wb = Application.Workbooks.Add

    'open Workbook with the data
    Set data_wb = Application.Workbooks.Open(file_name)
    
    'get quantity to create loop
    quantity = _
    InputBox("How many columns do you want to copy?")
    
    'loop
    For counter = 1 To quantity
    
        'select header range
        Set header_range(counter) = _
        Application.InputBox("Select the HEADER of the " & counter & "º column you want to copy", Type:=8)
        
        'get last row and col letter
        col_number = header_range(counter).Column
        last_row = Cells(Rows.Count, col_number).End(xlUp).Row
        col_letter = Split(Cells(1, col_number).Address(True, False), "$")(0)

        'copy from data_wb
        Range(header_range(counter), Range(col_letter & last_row)).Copy
        
        'pastein target_wb
        target_wb.Sheets("Sheet1").Cells(1, counter).PasteSpecial
        
    Next counter
    
    data_wb.Close
    
    If Not target_wb.Saved Then
        If MsgBox("Do you want to save the file?", vbYesNo, "Save?") = vbYes Then
            target_wb.Save
        End If
    End If

End If

target_wb.Close

End Sub