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

試試這個（注釋）代碼

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

我認為您可以將所有列復制到臨時表，然后編寫一些代碼以刪除無用的列。 最后將表格粘貼到您的預期區域。