Excel VBA 宏:导入工作簿、复制列和循环访问导入的工作簿

Question

我正在尝试为我的 Finance VBA 课程组创建一个复制工具，该工具允许用户导入一系列工作簿，从每个工作簿中复制相同的几列，并将这些列聚合到单个工作簿中。

为方便起见，我附加了一组示例导入文件以及这些文件的所需输出。

同样需要注意的是，在 Q1 和 Q2 中，它只是复制了 B 列。但是，在 Q3 中，复制的是列 B 和 C。

这是我在下面的当前代码。目前，它仅从 1 个工作簿复制，并且只是在工作簿的其余部分重复同一列（尽管我能够导入多个工作簿）。任何帮助将不胜感激！谢谢！

Sub import()
Dim OutputWorkbook As Workbook, InputWorkbook As Workbook, lInputWorkbookName As String, fDialog As Office.FileDialog, _
varFile As Variant, i As Long, sheet As Worksheet, cell As Range, _
Interest_Income As Range, temp As String, sourceColumn As Range,  targetColumn As Range _
ThisWorkbook.Activate
On Error GoTo handler
Set OutputWorkbook = ThisWorkbook
Set targetColumn = OutputWorkbook.Sheets("Taxable Income Aggregate").Columns("C:XED")

ThisWorkbook.Activate
  ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogOpen)
   With fDialog
      Application.DisplayAlerts = False
      Application.ScreenUpdating = False
      Application.AskToUpdateLinks = False
      Application.CutCopyMode = False
  ' Allow user to make multiple selections in dialog box
      .AllowMultiSelect = True
  .Title = "Import Your Workbooks"
  .Filters.Clear
  .Filters.Add "Excel 97-2003 Workbook", "*.xls"
  .Filters.Add "Excel Workbook", "*.xlsx"
  .Filters.Add "Excel Binary Workbook", "*.xlsb"
  .Filters.Add "Macro-Enabled Workbook", "*.xlsm"
  .Filters.Add "All", "*.*"
  ' Show the dialog box.
      If .Show = True Then
        Application.ScreenUpdating = False
        For Each varFile In .SelectedItems
            Workbooks.Open (varFile)
            lInputWorkbookName = Mid(varFile, InStrRev(varFile, "") + 1)
            Set sheet = varFile.Sheets("Taxable Income Summary").Columns("B")
            For Each sheet In Workbooks(lInputWorkbookName).Sheets("Taxable Income Summary").Columns("B")
                sourceColumn.Copy Destination:=targetColumn
                'For populating Taxable Income Aggregate
                'If sheet.Name Like "Taxable Income Summary" Then
                'End If
            Next
            Workbooks(lInputWorkbookName).Close
         Next
         OutputWorkbook.Sheets("Taxable Income Aggregate").Activate

         Application.ScreenUpdating = True
         Application.DisplayAlerts = True
         Application.AskToUpdateLinks = True
         Application.CutCopyMode = True
      Else
         MsgBox "You clicked Cancel in the file dialog box."
      End If
   End With
Exit Sub
handler:
    MsgBox Err.Description
End Sub

复制工具 -> https://drive.google.com/file/d/0B-QauGO0OicTMEFEUlFvY28wNFU/view?usp=sharing

输入 3 -> https://drive.google.com/open?id=0B-QauGO0OicTUHJuMUs5UlVuU2s

Answer 1

除了我没有得到的"Q3 是 B 列和 C"（如何知道何时执行此操作）之外，这应该可以工作：

Sub import()
  On Error GoTo handler
  ThisWorkbook.Activate
  Dim OutputWorksheet As Object
  Set OutputWorksheet = ThisWorkbook.Sheets("Taxable Income Aggregate")
  Dim actCol As Long
  actCol = 3
  With Application.FileDialog(msoFileDialogOpen)
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False
    Application.CutCopyMode = False
    .AllowMultiSelect = True
    .Title = "Import Your Workbooks"
    .Filters.Clear
    .Filters.Add "All Excel Files", "*.xl*"
    .Filters.Add "All Files", "*.*"
    If .Show = True Then
      Application.ScreenUpdating = False
      Dim varFile As Variant    
      For Each varFile In .SelectedItems
        With Workbooks.Open(varFile)
          Dim xSheet As Object
          For Each xSheet In .Sheets
            If xSheet.Name Like "*Taxable Income Summary*" Then
              'Don't know how to ckeck for Q3
              'You still need to add that code
              xSheet.Columns("B").Copy OutputWorksheet.Column(actCol)
              actCol = actCol + 1
            End If
          Next
          .Close 0
        End With
      Next
      OutputWorksheet.Activate
    Else
      MsgBox "You clicked Cancel in the file dialog box."
    End If
  End With
  Application.AskToUpdateLinks = True
  Exit Sub
handler:
  MsgBox Err.Description
  Application.AskToUpdateLinks = True
End Sub

DisplayAlerts和ScreenUpdating将自动设置为True（因此无需手动操作），CutCopyMode永远不需要转到"True"（实际上：它根本无法转换为True）

我还"跳过"了你的一些变量。

要复制到的目标通过actCol

其余的应该自我解释给你。

如果您仍有疑问或麻烦，请撰写评论。