Копирование определенного столбца из одного файла в другой вместо всех столбцов

Question

Может кто-нибудь, пожалуйста, помогите. У меня есть некоторый код, который работает для импорта данных из одного файла в другой. Однако изменение, которое я ищу, заключается в том, чтобы вносить только определенные столбцы, например столбцы A, B и F, например. Может кто-нибудь, пожалуйста, помогите мне понять, как это сделать.

Я думаю, что это как-то связано с этим кодом, но я не уверен, как его реализовать.

 Sheets("Data").Columns(1).Copy Destination:=Sheets("Data").Columns(2)

Основной код:

Sub ImportData()

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range

Set wb1 = ActiveWorkbook
Set PasteStart = [Data!A1]

FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.csv (*.csv),")

If FileToOpen = False Then
    MsgBox "No File Specified.", vbExclamation, "ERROR"
    Exit Sub
Else
    Set wb2 = Workbooks.Open(Filename:=FileToOpen)

    For Each Sheet In wb2.Sheets
        With Sheet.UsedRange
            .Copy PasteStart
            Set PasteStart = PasteStart.Offset(.Rows.Count)
        End With
    Next Sheet

End If

    wb2.Close

End Sub

РЕДАКТИРОВАТЬ: Обновлено на основе ответа ниже:

Sub ImportData()

Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range

Set wb1 = ActiveWorkbook
Set PasteStart = [Data!A1]

FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.csv (*.csv),")

If FileToOpen = False Then
    MsgBox "No File Specified.", vbExclamation, "ERROR"
    Exit Sub
Else
    Set wb2 = Workbooks.Open(Filename:=FileToOpen)

    wb2.Worksheets("Sheet1").Range("A:A").Copy wb1.Worksheets("Sheet1").Range("A:A")

End If

    wb2.Close

End Sub

Answer 1

Возможно, я слишком упростил это, но если вы просто хотите скопировать столбцы на другой лист, попробуйте это:

РЕДАКТИРОВАТЬ: Добавлена ​​опция выбора файлов

Sub CopySpecificColumns()

    Dim oSourceWB As Workbook
    Dim oSourceSheet As Worksheet
    Dim oDestSheet As Worksheet: Set oDestSheet = ThisWorkbook.Worksheets("Sheet4")         ' Set your destination sheet here
    Dim aColsToCopy, aDestColumns, sWBToOpen
    Dim iC As Long

    ' Get filename
    sWBToOpen = Application.GetOpenFilename("Report Files (*.csv),", , "Please chose a Report to Parse", , False)

    ' Check that a file was selected
    If sWBToOpen = "False" Then Exit Sub

    ' Open workbook and set source sheet
    Set oSourceWB = Workbooks.Open(sWBToOpen)
    Set oSourceSheet = oDestWB.Sheets("Checklist")

    aColsToCopy = Array("B", "C", "E")      ' Set your cource columns here
    aDestColumns = Array("A", "B", "C")     ' Set your destination columns here

    ' Loop to copy columns
    For iC = LBound(aColsToCopy) To UBound(aColsToCopy)
        With oSourceSheet
            .Range(aColsToCopy(iC) & "1:" & aColsToCopy(iC) & .Range(aColsToCopy(iC) & .Rows.Count).End(xlUp).Row).Copy oDestSheet.Range(aDestColumns(iC) & "1")
        End With
    Next

    ' Close source workbook
    oSourceWB.Close False

    ' Clear objects
    Set oSourceSheet = Nothing
    Set oDestSheet = Nothing
    Set oSourceWB = Nothing

End Sub

Вы можете добавлять такие вещи, как отсутствие обновления экрана, если хотите

Answer 2

Не легко передать это в комментарии.

Попробуйте изменить цикл следующим образом:

For Each Sheet In wb2.Sheets
    With Sheet
        Intersect(.UsedRange, .Range("A:A,B:B,F:F")).Copy PasteStart
        Set PasteStart = Sheets("Data").Range("A" & Rows.Count).End(xlUp)(2)
    End With
Next Sheet

У вас есть одинаковое количество строк данных в каждом столбце? Если нет, вам нужно будет это разрешить.