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

Question

I want to copy a table into a new Workbook while choosing which range I want to copy and knowing that the first Columns ("A") is automatically copied. (rows are not a problem, all of them have to be copied) For example, i have a table composed of 28 rows and 10 columns. Added to A1:A28 (first columns, all rows),i want just to copy the column 5 and 8 with all its rows. That's what i have until now but it doesn't work.

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

Can you help please solving it? Thanks in advance!

Answer 1

try this (commented) code

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

You can't copy a non-continuous range but you can load the data into an array and write it once to the new workbook.

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

I think you can copy all column to a temp sheet and then write some code to delete the useless column. finally paste the table to your expected area.