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

我想在选择要复制的范围并知道第一列（“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

---

你能帮我解决吗？提前谢谢

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

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

尝试此（注释）代码

选项显式
子命令按钮1_单击（）
Dim newSht As工作表
暗咖喱线
模糊区域作为范围
长的
Set newSht=Workbooks.add.Worksheets（“Feuil1”）”试试这段（注释过的）代码

选项显式
子命令按钮1_单击（）
Dim newSht As工作表
暗咖喱线
模糊区域作为范围
长的
Set newSht=Workbooks.add.Worksheets（“Feuil1”）”不能复制非连续范围，但可以将数据加载到数组中，并将其写入新工作簿一次


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


“复制列5和列8及其所有行”实际上是什么意思？发布输入和输出数据的示例例如，我有一个由a到G的28行和列组成的表作为输入。作为输出，我希望从我的输入中得到一个由28行组成的表，并且只包含a、C和F列（因此它由从我的输入中提取的三列组成），在您的代码中，我从哪里得到1）输入表2）要选择的列？在currentWB.currentS中，我已经从中选择了我的表，我将选择我的列。在注释后面：“选择要复制的列；我开始选择列，CurrCols是我要复制的列集合rng=currentWB.currentS.Range（单元格（1，CurrCols），单元格（28，CurrCols））。Select rng.copy是复制并粘贴此列，但它不起作用！！currentS.Range（“A1:A27”）.Select.copy只是复制第一列的所有行，因为我总是需要它，“复制第5列和第8列的所有行”实际上是什么意思？发布输入和输出数据的示例例如，我有一个由a到G的28行和列组成的表作为输入。作为输出，我希望从我的输入中得到一个由28行组成的表，并且只包含a、C和F列（因此它由从我的输入中提取的三列组成），在您的代码中，我从哪里得到1）输入表2）要选择的列？在currentWB.currentS中，我已经从中选择了我的表，我将选择我的列。在注释后面：“选择要复制的列；我开始选择列，CurrCols是我要复制的列集合rng=currentWB.currentS.Range（单元格（1，CurrCols），单元格（28，CurrCols））。Select rng.copy是复制并粘贴此列，但它不起作用！！currentS.Range（“A1:A27”）.Select Selection.copy只是复制第一列和所有行，因为我总是需要它。没有解决方案可以只选择我要复制的列，并将它们合并，然后粘贴？如果您合并它们。假设您要复制第5列和第8列。您粘贴的结果可能在第5列和第6列，因为粘贴区域必须是连续的。如果您认为可以，请将我的答案向上投票。谢谢。很抱歉我在旅行，没有上网！我现在才明白！！我会尝试一下，并给你一个反馈。谢谢，Chan，它工作得很好！我只想保持每列和每行的格式和颜色相同！没有办法只选择要复制的列，并将其作为并集，然后粘贴（如果您并集它们）。假设您要复制第5列和第8列。您粘贴的结果可能在第5列和第6列，因为粘贴区域必须是连续的。如果您认为可以，请将我的答案向上投票。谢谢。很抱歉我在旅行，没有上网！我现在才明白！！我会尝试一下，并给你一个反馈。谢谢，Chan，它工作得很好！我只想保持每列和每行的格式和颜色相同！
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

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