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

我想复制一个表到一个新的工作簿，同时select我想复制的范围，并知道第一列（“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

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