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