Перенос нескольких столбцов из одной рабочей книги в другую

Question

Я хочу перенести несколько столбцов в новую книгу с именем «Мои данные» в указанные соответствующие столбцы. Я пробовал этот код, но он слишком длинный, и я хочу сделать его коротким, и после завершения процесса я хочу закрыть новую рабочую книгу, не зная, как это сделать.

Sub transfer()
Dim MyData As Workbook
Dim DataWs As Worksheet
Dim myWs As Worksheet
Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("C3:C11000").Copy
DataWs.Range("E2").PasteSpecial xlPasteAll

Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("E3:E11000").Copy
DataWs.Range("F2").PasteSpecial xlPasteAll

Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("G3:G11000").Copy
DataWs.Range("G2").PasteSpecial xlPasteAll

Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("I3:I11000").Copy
DataWs.Range("H2").PasteSpecial xlPasteAll

Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("K3:K11000").Copy
DataWs.Range("I2").PasteSpecial xlPasteAll

Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("M3:M11000").Copy
DataWs.Range("J2").PasteSpecial xlPasteAll


Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")
myWs.Range("U3:U11000").Copy
DataWs.Range("M2").PasteSpecial xlPasteAll


  MyData.Save

  End Sub

Answer 1

Вставить диапазоны столбцов

Особенности

• Назначены все значения констант.
• Добавлена ​​проверка открытия рабочей книги.
• Уменьшены ссылки на объекты на одном листе.
• Заменено копирование / вставка копией (назначение).

Настройте значения в разделе констант в соответствии со своими потребностями.

Код

Sub transfer()

    ' Source
    Const cSource As Variant = "FinalinputFile"   ' Worksheet Name/Index
    Const cSFirst As Integer = 3                  ' First Row Number
    Const cLast As Integer = 11000                ' Last Row Number
    Const cSCols As String = "C,E,G,I,K,M,U"      ' Column List
    ' Target
    Const cPath As String = "D:\Desktop\My\"      ' Workbook Path
    Const cName As String = "MyData.xlsx"         ' Workbook Name
    Const cTarget As Variant = "Data"             ' Worksheet Name/Index
    Const cTFirst As Integer = 2                  ' First Row Number
    Const cTCols As String = "E,F,G,H,I,J,M"      ' Column List

    Dim DataWs As Worksheet   ' Target Worksheet
    Dim vntS As Variant       ' Source Column Array
    Dim vntT As Variant       ' Target Column Array
    Dim i As Integer          ' Columns Counter

    ' Check if Target Workbook is already open.
    For i = 1 To Workbooks.Count
        If Workbooks(i).Name = cName Then Exit For
    Next

    ' Create reference to Target Worksheet.
    If i > Workbooks.Count Then ' Target Workbook is not open.
        Set DataWs = Workbooks.Open(cPath & cName).Worksheets(cTarget)
      Else                      ' Target Workbook is open.
        Set DataWs = Workbooks(i).Worksheets(cTarget)
    End If

    ' Write Column Lists into Column Arrays.
    vntS = Split(cSCols, ",")
    vntT = Split(cTCols, ",")

    ' Copy Source Column Ranges to Target Columns Ranges.
    With ThisWorkbook.Sheets(cSource)
        For i = 0 To UBound(vntS) ' or Ubound(vntT) - it's the same.
            .Range(.Cells(cSFirst, vntS(i)), .Cells(cLast, vntS(i))).Copy _
            DataWs.Cells(cTFirst, vntT(i))
        Next
    End With

    ' Save and close Target Workbook using Parent property.
    With DataWs.Parent
        .Close True ' True saves the workbook.
    End With

    Set DataWs = Nothing

End Sub

Answer 2

Эта часть вашего кода

Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")

Повторяется даже при том, что каждый раз одно и то же, без него ваш код должен быть в порядке, поэтому вы можете сократить его, удалив повторения.

Кроме того, код для закрытия рабочей книги - Workbooks("MyData").Close, но вы должны сохранить его, и лучше назвать полное имя, например Workbooks("MyData").Save

Итак, ваш окончательный код будет выглядеть примерно так:

Sub transfer()
Dim MyData As Workbook
Dim DataWs As Worksheet
Dim myWs As Worksheet
Set myWs = ThisWorkbook.Sheets("FinalinputFile")
Set MyData = Workbooks.Open("D:\Desktop\My\MyData.xlsx")
Set DataWs = MyData.Sheets("Data")

myWs.Range("C3:C11000").Copy
DataWs.Range("E2").PasteSpecial xlPasteAll
myWs.Range("E3:E11000").Copy
DataWs.Range("F2").PasteSpecial xlPasteAll
myWs.Range("G3:G11000").Copy
DataWs.Range("G2").PasteSpecial xlPasteAll
myWs.Range("I3:I11000").Copy
DataWs.Range("H2").PasteSpecial xlPasteAll
myWs.Range("K3:K11000").Copy
DataWs.Range("I2").PasteSpecial xlPasteAll
myWs.Range("M3:M11000").Copy
DataWs.Range("J2").PasteSpecial xlPasteAll
myWs.Range("U3:U11000").Copy
DataWs.Range("M2").PasteSpecial xlPasteAll 

Workbooks("MyData").Save
Workbooks("MyData").Close

End Sub