如何使用vba将已closures的工作簿中的列复制到另一个工作簿？

在一个文件夹中，我有30个相同格式的工作簿*，相同的行数和列数。现在我想从所有的工作簿复制一些特定的列*。 'F'，'J'，'N'，'R'，'V'，'Z'，'AD'，'AH'，'AL'，'AP'，' AT'，'AX'。

*注1 =所有工作簿中只有一张。 [N个工作簿= n张]

*注2 =这些列是固定的…只有这些列必须被提取。

所做的是：

复制'F'栏

Sub CopyingRange() Workbooks("workbook1 name").Sheets("Sheetname").Range("F2:F453").Copy Range("A1:A453") Workbooks("workbook2 name").Sheets("Sheetname").Range("F2:F453").Copy Range("B1:B453") ... Workbooks("workbookn name").Sheets("Sheetname").Range("F2:F453").Copy Range("Z1:Z453") End Sub 

“J”列和其他列也是如此。

问题：

1）我的过程是非常基本的。

2）在运行程序时，工作簿必须打开。

3）耗时。

有没有其他的方式来做到这一点..我想复制列而不打开工作簿。

Answer 1

您需要打开所有工作簿，复制所有数据，然后再closures所有工作簿。

这应该做到这一点：

 Sub CopyingRange() Dim ColNames As String Dim ColS() As String Dim ReportWs As Worksheet Dim DestCol As Long Dim WbCol As Collection Dim wB As Workbook With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With ColNames = "F/J/N/R/V/Z/AD/AH/AL/AP/AT/AX" ColS = Split(ColNames, "/") ReportWs = ThisWorkbook.Sheets("SheetName") DestCol = 1 WbCol.Add Workbooks.Open("C:/Path/workbook1 name.xlsx") DoEvents '... same for the others For i = LBound(ColS) To UBound(ColS) For Each wB In WbCol ReportWs.Range(Col_Letter(DestCol) & "2:" & Col_Letter(DestCol) & "453").Value = _ wB.Sheets(1).Range(ColS(i) & "2:" & ColS(i) & "453").Value DestCol = DestCol + 1 Next wB Next i For Each wB In WbCol wB.Close Next wB With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub Function Col_Letter(lngCol As Long) As String Col_Letter = CStr(Split(Cells(1, lngCol).Address(True, False), "$")(0)) End Function