VBA Excel将表格复制并粘贴到新工作簿中，然后选择我要复制的列

Question

我想将一个表复制到一个新的工作簿中，同时选择我要复制的范围并且知道第一列（“A”）会自动复制。 （行不是问题，都得复制） 例如，我有一个由 28 行和 10 列组成的表。添加到 A1:A28 （第一列，所有行），我只想复制第 5 列和第 8 列及其所有行。 这就是我到目前为止所拥有的，但它不起作用。

Sub CommandButton1_Click()
  Dim newWB As Workbook, currentWB As Workbook
  Dim newS As Worksheet, currentS As Worksheet
  Dim CurrCols As Variant
  Dim rng As rang
  'Copy the data you need
    Set currentWB = ThisWorkbook
    Set currentS = currentWB.Sheets("Feuil1")
    'select which columns you want to copy
    CurrCols = InputBox("Select which column you want to copy from        table (up to 10)")
    If Not IsNumeric(CurrCols) Then
    MsgBox "Please select a valid Numeric value !", vbCritical
    End
    Else
    CurrCols = CLng(CurrCols)
    End If
    'Set rng = currentWB.currentS.Range(Cells(1, A), Cells(27, CurrCols)).Select
    currentS.Range("A1:A27").Select
    Selection.copy
    Set rng = currentWB.currentS.Range(Cells(1, CurrCols), Cells(28, CurrCols)).Select
    rng.copy
    'Create a new file that will receive the data
    Set newWB = Workbooks.Add
    With newWB
    Set newS = newWB.Sheets("Feuil1")
    newS.Range("A1").PasteSpecial Paste:=xlPasteValues,    Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
End With
End Sub

你能帮忙解决一下吗？提前致谢！

Answer 1

您不能复制非连续范围，但可以将数据加载到数组中，然后将其写入新工作簿一次。

Private Sub CommandButton1_Click()
    Dim arData
    Dim MyColumns As Range, Column As Range
    Dim x As Long, y As Long

    On Error Resume Next
    Set MyColumns = Application.InputBox(Prompt:="Hold down [Ctrl] and click the columns to copy", Title:="Copy Columns to new Workbook", Type:=8)
    On Error GoTo 0

    If MyColumns Is Nothing Then Exit Sub

    Set MyColumns = Union(Columns("A"), MyColumns.EntireColumn)

    Set MyColumns = Intersect(MyColumns, ActiveSheet.UsedRange)

    ReDim arData(1 To MyColumns.Rows.Count, 1 To 1)

    For Each Column In MyColumns.Columns
        y = y + 1
        If y > 1 Then ReDim Preserve arData(1 To MyColumns.Rows.Count, 1 To y)
        For x = 1 To Column.Rows.Count
            arData(x, y) = Column.Rows(x)
        Next
    Next

    With Workbooks.Add().Worksheets(1)
        .Range("A1").Resize(UBound(arData, 1), UBound(arData, 2)) = arData
        .Columns.AutoFit
    End With
End Sub

Answer 2

试试这个（注释的）代码

Option Explicit

Sub CommandButton1_Click()
    Dim newSht As Worksheet
    Dim currCols As String
    Dim area As Range
    Dim iArea As Long

    Set newSht = Workbooks.add.Worksheets("Feuil1") '<--| add a new workbook and set its "Feuil1" worksheet as 'newSht'
    currCols = Replace(Application.InputBox("Select which column you want to copy from table (up to 10)", "Copy Columns", "A,B,F", , , , , 2), " ", "") '<--| get columns list

    With ThisWorkbook.Worksheets("Feuil1") '<--| reference worksheet "Feuil1" in the workbook this macro resides in
        For Each area In Intersect(.Range(ColumnsAddress(currCols)), .Range("A1:G28")).Areas ' loop through referenced worksheet areas of the range obtained by crossing its listed columns with its range "A1:G28"
            With area '<--| reference current area
                newSht.Range("A1").Offset(, iArea).Resize(.Rows.Count, .Columns.Count).value = .value '<--| copy its values in 'newSht' current column offset from "A1" cell
                iArea = iArea + .Columns.Count '<--| update current column offset from 'newSht' worksheet "A1" cell
            End With
        Next area
    End With
End Sub

Function ColumnsAddress(strng As String) As String
    Dim elem As Variant

    For Each elem In Split(strng, ",")
        ColumnsAddress = ColumnsAddress & elem & ":" & elem & ","
    Next
    ColumnsAddress = Left(ColumnsAddress, Len(ColumnsAddress) - 1)
End Function

Answer 3

我认为您可以将所有列复制到临时表，然后编写一些代码来删除无用的列。最后将表格粘贴到您预期的区域。