粘贴列范围

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

这部分代码

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

Answer 2

粘贴列范围

要点

将所有值分配给常量。
添加了工作簿打开检查。
减少了对一个工作表的对象引用。
用副本（目标）替换了副本/粘贴。

调整常量部分中的值以适合您的需求。

代码

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

将多个列从一个工作簿转移到另一个工作簿

2 个答案:

粘贴列范围

要点

代码