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

Вы не можете копировать, не непрерывный диапазон, но вы можете загрузить данные в массив и записать его один раз в новую книгу.

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

Я думаю, вы можете скопировать весь столбец на временный листок, а затем написать код для удаления бесполезного столбца. наконец, вставьте таблицу в ожидаемую область.

Answer 3

попробовать это (с комментариями) Код

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