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

试试这个（评论过的）代码

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 2

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

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 3

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

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

3 个答案: