Question

我试图在一系列单元格中复制多个文件中的数据。

我做了一些事情，但我必须在特定路径中保存文件，或者有时手动复制一个工作簿中的单元格范围。

我想选择工作簿并保存现有工作簿，因为标题可以包含一些引用，有时文件包含受保护的VBA项目。

我的代码从第一个工作表中复制一行，从第二个工作表中复制一系列单元格，从指定文件夹中打开的文件复制，然后将这些单元格保存到代码所在的文件中。

"Eclipse Project Test Site" - http://download.eclipse.org/eclipse/updates/3.7

The Eclipse Project repository - http://download.eclipse.org/eclipse/updates/4.5

The Eclipse Project repository - http://download.eclipse.org/eclipse/updates/4.6

http://download.eclipse.org/eclipse/updates/3.7/R-3.7.2-201202080800

Answer 1

我希望我做对了......

你想要：

从特定文件夹中动态选择文件
将工作表1和2中所选文件中的单元格复制到当前工作簿
保存当前的工作簿？（我不完全明白你的意思，所以我把这部分留了出来）

我接受它：

使用列表框（lstFile，2列）和命令按钮（cmdCopy）创建用户表单（ufCopy）
在工作表上创建一个命令按钮以启动它
在附加内容中检查“Microsoft脚本运行时” - ＆gt;参考以避免必须创建对象
将此代码复制到userforms源代码

代码：

    Private Sub UserForm_Initialize()

        Call GetFiles("C:\example\example") 'Enter your folder path here

    End Sub

    Private Sub GetFiles(strFile As String)

        '
        'Populates Listbox with all Excel files in the chosen folder and subfolders
        '

        Dim fso As Scripting.FileSystemObject
        Dim fsoFolder As Scripting.Folder
        Dim fsoSubfolder As Scripting.Folder
        Dim fsoFile As Scripting.File

        Set fso = New Scripting.FileSystemObject
        Set fsoFolder = fso.GetFolder(strFile)

        For Each fsoFile In fsoFolder.Files

            If Left(fso.GetExtensionName(fsoFile.Path), 2) = "xl" Then
                With Me.lstFiles
                    .AddItem
                    .List(.ListCount - 1, 0) = fsoFile.Name
                    .List(.ListCount - 1, 1) = fsoFile.Path
                End With
            End If

        Next fsoFile

        For Each fsoSubfolder In fsoFolder.SubFolders

            Call GetFiles(fsoSubfolder.Path)

        Next fsoSubfolder

    End Sub

    Private Sub cmdCopy_Click()

        Dim Msg As String
        Dim iCounter As Integer
        Dim wbCur As Workbook

        Application.ScreenUpdating = False   

        For iCounter = 0 To Me.lstFiles.ListCount - 1

             If Me.lstFiles.Selected(iCounter) Then

                Set wbCur = Workbooks.Open(Me.lstFiles.List(iCounter, 0) & Me.lstFiles.List(iCounter, 1))
                '
                'Copy from first sheet
                '
                wbCur.Worksheets(1).Range("A2:M2").Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                '
                'Copy from second sheet
                '
                With wbCur.Worksheets(2)
                    .Range("A1", .Range("A2").End(xlDown).End(xlToRight)).Copy Destination:=ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End With

                wbCur.Close savechanges:=False

              End If
        Next iCounter

        Application.ScreenUpdating = True
    End Sub

这样做：

在多选列表框中显示所选文件夹和子文件夹的所有Excel文件
循环浏览所有选定的工作簿并将单元格复制到此

我没有看到该数组的目的，所以我删除了它。您可以自由调整代码以便根据您的需要进行复制。

要启动用户窗体，请将其复制到包含命令按钮的工作表的代码中：

Private Sub CommandButton1_Click()

    ufCopy.Show

End Sub

编辑：要动态选择文件夹路径，请使用：

Private Sub UserForm_Initialize()

Dim strFolder
Dim fdFolder As FileDialog

' Open the file dialog
Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.AllowMultiSelect = False
fdFolder.Show

strFolder = fdFolder.SelectedItems(1)

Call GetFiles(strFolder)

End Sub

如果要从不同路径获取文件，只需将上述代码添加到用户表单上的命令按钮而不是初始化。这样你可以点击它并添加多个目录。

Answer 2

对您的代码的评论

Application.DisplayAlerts = False表示用户不会看到任何提醒。在我看来，这很危险。我使用这句话：

Application.DisplayAlerts = False
Delete worksheet
Application.DisplayAlerts = True

也就是说，我关闭单个语句的警报。我已经与用户核实过，如果合适，可以删除工作表。

If MyFile = "Transport_data.xlsm" Then
  Exit Sub
End If

我假设Transport_data.xlsm是包含宏的工作簿。通常，Dir按创建的顺序返回文件，因此不会处理在Transport_data.xlsm之后创建的任何文件。你想要这样的东西：

If MyFile <> "Transport_data.xlsm" Then
  Process file
End If

值得注意的是，ThisWorkbook.Name给出了持有正在运行的宏的工作簿的名称。因此，如果更改工作簿的名称，以下内容仍然有效：

If MyFile <> ThisWorkbook.Name Then
  Process file
End If

Worksheets(N)是Tab上的第N个工作表。如果用户更改工作表的顺序，则工作表编号会更改，您可能无法获得预期的工作表。

始终按名称标识工作表：Worksheets("xxxxx")

Worksheets(N)Activate很慢，应该避免。

在下文中，您激活Worksheets(2)，然后完全限定您想要的工作表以下声明：

Worksheets(2).Activate
erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

您不需要Activate

您使用

`ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice`

下载到目标范围，但逐个单元格从源范围加载Matrice。您可以以相同的方式加载Matrice。

Dim Matrice As Variant

Matrice = SourceRange.Value          ' This will size Matrice as required
DestinationRange.Value = Matrice

您的要求

您希望从多个工作簿中提取数据，而不是全部存储在同一文件夹中。您假设（希望）您需要的工作表是第一个工作表。您的宏复制整个工作表，但您的文本暗示您希望更具选择性。由于您希望自动化该过程，我认为这是一个每隔一段时间重复的过程。

我可能会得出结论，但这听起来像是我的一个客户的要求。他们从他们的来源收到了多本工作簿，但他们只需要选择的信息用于他们的管理摘要。他们手动执行合并，这非常耗时且容易出错。如果您的要求类似于他们的要求，则您不希望用户选择文件;您希望该过程完全自动化。我不再拥有我为该客户端创建的代码，但我已经从内存中创建了一个简单的版本。

我创建了一个包含名为“Instructions”的工作表的工作簿。他们有多个这样的工作表，因为他们有几个合并。但是，足以证明这一原则。工作表有多行。每行指定从一个工作簿到另一个工作簿的范围复制。列是：

Source         Folder
range          Workbook name
               Worksheet name
               Left column      \
               Top row          |  Source range
               Right column     |
               Bottom row       /

Destination    Folder
range          Workbook name
               Worksheet name
               Top left destination cell

这是我的测试数据的图像：

注意：此数据旨在测试宏;这不是一套特别明智的指示。

在我为客户端创建的系统和我为您创建的简单宏中，Folder是一个固定的字符串。例如：“C：\ Users \ noStress \ Desktop \ Workbook test \ Destinatia mea”或“C：\ Users \ ajdal \ Desktop \ Workbooks \ CopyRanges”。必须在第一个指令行上指定文件夹名称。如果它发生变化，只需要在后续行中指定。

在我为您创建的宏中，工作簿名称已修复。例如：“A.xlsx”或“B.xlsx”。在我的客户端系统中，它是一个模板，例如：“Branch A * .xlsx”。宏将从匹配此模板的文件夹中选择最新文件。

在两个系统中，工作表名称都是固定的。

注意：如果指定了新文件夹，则需要新的工作簿名称和新工作表名称。如果指定了新的工作簿名称，则需要新的工作表名称。

目标文件夹，工作簿和工作表的规则与源相同。

目的地只需要左上角的单元格。我已经包含了允许“D”或“A”作为目的地的代码，这意味着从前一个副本开始或从前一个副本开始。

如果指令行中的值丢失或错误，则单元格将显示为Rose，并忽略该行。宏继续下一行，因此可以一次性测试尽可能多的指令。例如：

宏可能有太多的验证和测试不够。对于客户，非技术人员创建了指令工作表。如果他们拼错了工作簿或工作表名称，宏不能只停止工作簿打开或工作表访问，所以一切都经过验证。我已经包含了验证但没有测试每个可能的用户错误。我总是通过我的宏在每条路径的顶部包含Debug.Assert False。在测试期间，执行路径时，我会注释掉Debug.Assert False。任何在测试结束时仍然没有注释的表明我的测试不合适或者我的设计有问题并且无法到达路径。这里指出我没有测试的错误条件。

注意：我使用SourceRange.Copy Destination:=TopLeftCell复制数据。这样做的好处是复制了格式，但缺点是公式也被复制。如果这是不可接受的，通过Variant数组进行复制可能会更好。

如果此功能听起来很有趣，请玩宏。

Option Explicit

  Const ClrError As Long = 13408767   ' Rose = RGB(255, 153, 204)
  Const ClrSrc As Long = 10092543     ' Light yellow = RGB(255, 255, 153)
  Const ClrDest As Long = 16777164    ' Light turquoise - RGB(204, 255, 255)

  Const ColInstSrcFld As Long = 1
  Const ColInstSrcWbk As Long = 2
  Const ColInstSrcWsht As Long = 3
  Const ColInstSrcColLeft As Long = 4
  Const ColInstSrcRowTop As Long = 5
  Const ColInstSrcColRight As Long = 6
  Const ColInstSrcRowBot As Long = 7
  Const ColInstDestFld As Long = 8
  Const ColInstDestWbk As Long = 9
  Const ColInstDestWsht As Long = 10
  Const ColInstDestRng As Long = 11
  Const ColsSrc As String = "A:G"     ' \ Used for colouring columns
  Const ColsDest As String = "H:K"    ' /
Sub CopyRanges()

  Dim ColDest As Long
  Dim ColSrcLeft As Long
  Dim ColSrcRight As Long
  Dim DestFldStr As String
  Dim DestWbkStr As String
  Dim DestWbkChanged As Boolean
  Dim DestWshtStr As String
  Dim DestRngStr As String
  Dim ErrorOnRow As Boolean
  Dim NumColsRngSrc As Long
  Dim NumRowsRngSrc As Long
  Dim RngDest As Range
  Dim RngSrc As Range
  Dim RowDest As Long
  Dim RowInstCrnt As Long
  Dim RowInstLast As Long
  Dim RowSrcBot As Long
  Dim RowSrcTop As Long
  Dim SrcFldStr As String
  Dim SrcWbkStr As String
  Dim SrcWshtStr As String
  Dim WbkDest As Workbook
  Dim WbkSrc As Workbook
  Dim WshtDest As Worksheet
  Dim WshtInst As Worksheet
  Dim WshtSrc As Worksheet

  ' Note the initial values for variables are:
  '   0  for Long
  '   "" for String
  '   Nothing for Object (for example: workbook, worksheet, range)

  Application.ScreenUpdating = False

  Set WshtInst = Worksheets("Instructions")

  With WshtInst
    ' Restore background colour of source and destination columns
    ' to clear and error recorded by last run.
    .Columns(ColsSrc).Interior.Color = ClrSrc
    .Columns(ColsDest).Interior.Color = ClrDest

    ' Find last row of instructions
    RowInstLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
  End With

  For RowInstCrnt = 3 To RowInstLast

    With WshtInst
      ErrorOnRow = False

      ' Validate source columns of instructions
      If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then
        ' New source folder; must be new workbook and worksheet
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWbk).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      ElseIf .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then
        ' New source workbook; must be new worksheet
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then
          'Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If

      ' Source range must always be specified in full

      ' Top row must be non-empty, numeric and a valid row number
      If .Cells(RowInstCrnt, ColInstSrcRowTop).Value = "" Then
        'Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowTop).Value) Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        RowSrcTop = .Cells(RowInstCrnt, ColInstSrcRowTop).Value
        If RowSrcTop < 1 Or RowSrcTop > Rows.Count Then
          .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If

      ' Left column must be non-empty and a valid column code
      If .Cells(RowInstCrnt, ColInstSrcColLeft).Value = "" Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        ColSrcLeft = ColNum(.Cells(RowInstCrnt, ColInstSrcColLeft).Value)
        If ColSrcLeft = 0 Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError  ' Record faulty value
        End If
      End If

      ' Bottom row must be non-empty, numeric and a valid row number greater or equal to top row
      If .Cells(RowInstCrnt, ColInstSrcRowBot).Value = "" Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowBot).Value) Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        RowSrcBot = .Cells(RowInstCrnt, ColInstSrcRowBot).Value
        If RowSrcBot < 1 Or RowSrcBot > Rows.Count Or RowSrcTop > RowSrcBot Then
          .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If

      ' right column must be non-empty and a valid column code greater or equal to left column
      If .Cells(RowInstCrnt, ColInstSrcColRight).Value = "" Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        ColSrcRight = ColNum(.Cells(RowInstCrnt, ColInstSrcColRight).Value)
        If ColSrcRight = 0 Or ColSrcLeft > ColSrcRight Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError  ' Record faulty value
        End If
      End If

      ' If no error in source columns, load new values from instruction row to variables.
      ' Check have value for every parameter. Check folder and workbook exist if specified
      ' Close old workbook if appropriate. Open new workbook if appropriate
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then
          ' New source folder
          'Debug.Assert False
          SrcFldStr = .Cells(RowInstCrnt, ColInstSrcFld).Value
          If Right$(SrcFldStr, 1) <> "\" Then
            'Debug.Assert False
            SrcFldStr = SrcFldStr & "\"
          End If
          If Not PathExists(SrcFldStr) Then
            Debug.Assert False
            .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError  ' Record faulty value
            SrcFldStr = ""
            ErrorOnRow = True
          End If
        ElseIf SrcFldStr = "" Then
          ' No source folder specified
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then
          ' New source workbook; close old one if any
          'Debug.Assert False
          If Not WbkSrc Is Nothing Then
            'Debug.Assert False
            WbkSrc.Close SaveChanges:=False
            Set WbkSrc = Nothing
          End If
          SrcWbkStr = .Cells(RowInstCrnt, ColInstSrcWbk).Value
          If FileExists(SrcFldStr, SrcWbkStr) Then
            'Debug.Assert False
            Set WbkSrc = Workbooks.Open(FileName:=SrcFldStr & SrcWbkStr, _
                                        UpdateLinks:=True, ReadOnly:=True)
          Else
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWsht).Value <> "" Then
          'Debug.Assert False
          SrcWshtStr = .Cells(RowInstCrnt, ColInstSrcWsht).Value
          If WshtExists(WbkSrc, SrcWshtStr) Then
            'Debug.Assert False
            Set WshtSrc = WbkSrc.Worksheets(SrcWshtStr)
          Else
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        Set RngSrc = WshtSrc.Range(WshtSrc.Cells(RowSrcTop, ColSrcLeft), _
                                   WshtSrc.Cells(RowSrcBot, ColSrcRight))
      End If

      ' Validate destination columns of instructions.
      If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then
        ' New destination folder; must be new workbook, worksheet and range
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWbk).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      ElseIf .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then
        ' New destination workbook; must be new worksheet and range
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If
      If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then
        ' Destination range must always be specified
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      End If

      ' If no error in destination columns, load new values from instruction row to variables.
      ' Check have value for every parameter. Check folder and workbook exist if specified
      ' Close old workbook if appropriate. Open new workbook if appropriate
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then
          ' New destination folder
          'Debug.Assert False
          DestFldStr = .Cells(RowInstCrnt, ColInstDestFld).Value
          If Right$(DestFldStr, 1) <> "\" Then
            DestFldStr = DestFldStr & "\"
          End If
          If Not PathExists(DestFldStr) Then
            Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError  ' Record faulty value
            DestFldStr = ""
            ErrorOnRow = True
          End If
        ElseIf DestFldStr = "" Then
          ' No destination folder specified
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then
          ' New destination workbook; close old one if any
          'Debug.Assert False
          If Not WbkDest Is Nothing Then
            'Debug.Assert False
            If DestWbkChanged Then
              'Debug.Assert False
              WbkDest.Close SaveChanges:=True
              DestWbkChanged = False
            Else
              Debug.Assert False
              WbkDest.Close SaveChanges:=False
            End If
            Set WbkDest = Nothing
          End If
          DestWbkStr = .Cells(RowInstCrnt, ColInstDestWbk).Value
          If FileExists(DestFldStr, DestWbkStr) Then
            'Debug.Assert False
            Set WbkDest = Workbooks.Open(FileName:=DestFldStr & DestWbkStr, _
                                         UpdateLinks:=True, ReadOnly:=False)
            DestWbkChanged = False
          Else
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        Else
          ' No new workbook. Check one remains open from previous instructions
          If WbkDest Is Nothing Then
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWsht).Value <> "" Then
          'Debug.Assert False
          DestWshtStr = .Cells(RowInstCrnt, ColInstDestWsht).Value
          If WshtExists(WbkDest, DestWshtStr) Then
            'Debug.Assert False
            Set WshtDest = WbkDest.Worksheets(DestWshtStr)
            ' Clear source range and destination cell information saved from
            ' previous instruction row and used in processing "destination cells"
            ' A(cross) and D(own).
            RowDest = 0
            ColDest = 0
            NumRowsRngSrc = 0
            NumColsRngSrc = 0
          Else
            Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        Select Case UCase(.Cells(RowInstCrnt, ColInstDestRng).Value)
          Case "D"    ' Down from previous transfer
            ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from
            ' last instruction row
            'Debug.Assert False
            If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then
              ' No appropriate previous instruction row
              Debug.Assert False
              .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
              ErrorOnRow = True
            Else
              'Debug.Assert False
              ' Calculate new row from information saved from last
              ' error-free instruction row.  Column unchanged.
              RowDest = RowDest + NumRowsRngSrc
            End If
          Case "A"    ' Across from previous transfer
            ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from
            ' last instruction row
            'Debug.Assert False
            If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then
              ' No appropriate previous instruction row
              Debug.Assert False
              .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
              ErrorOnRow = True
            Else
              'Debug.Assert False
              ' Calculate new column from information saved from last
              ' error-free instruction row. Row unchanged
              ColDest = ColDest + NumColsRngSrc
            End If
          Case Else
            'Debug.Assert False
            DestRngStr = .Cells(RowInstCrnt, ColInstDestRng).Value
            Err.Clear
            On Error Resume Next
            Set RngDest = WshtDest.Range(DestRngStr)
            On Error GoTo 0
            If Err <> 0 Then
              Debug.Assert False
              ' Faulty range
              .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
              ErrorOnRow = True
            Else
              ' Convert destination to numbers
              'Debug.Assert False
              ColDest = RngDest.Column
              RowDest = RngDest.Row
            End If
        End Select
      End If

    End With  ' WshtInst

    If Not ErrorOnRow Then

      ' All parameters stored ready for actioning

      RngSrc.Copy Destination:=WshtDest.Cells(RowDest, ColDest)
      DestWbkChanged = True
      ' Extract number of rows and columns from source range in case next
      ' instruction has "destination cell" as A(cross) or D(own)
      NumRowsRngSrc = RngSrc.Rows.Count
      NumColsRngSrc = RngSrc.Columns.Count

    End If

  Next

  If Not WbkSrc Is Nothing Then
    'Debug.Assert False
    WbkSrc.Close SaveChanges:=False
    Set WbkSrc = Nothing
  End If

  If Not WbkDest Is Nothing Then
    Debug.Assert False
    If DestWbkChanged Then
      Debug.Assert False
      WbkSrc.Close SaveChanges:=True
    Else
      Debug.Assert False
      WbkSrc.Close SaveChanges:=False
    End If
    Set WbkDest = Nothing
  End If

End Sub
Public Function ColNum(ByVal ColCode As String) As Long

  ' Checks ColCode is a valid column code for the version of Excel in use
  ' If it is, it returns the equivalent column number.
  ' If it is not, it returns 0.

  ' Coded by Tony Dallimore

  Dim ChrCrnt As String
  Dim ColCodeUc As String:   ColCodeUc = UCase(ColCode)
  Dim Pos As Long

  ColNum = 0

  For Pos = 1 To Len(ColCodeUc)
    ChrCrnt = Mid(ColCodeUc, Pos, 1)
    If ChrCrnt < "A" Or ChrCrnt > "Z" Then
      ColNum = 0
      Exit Function
    End If
    ColNum = ColNum * 26 + Asc(ChrCrnt) - 64
  Next

  If ColNum < 1 Or ColNum > Columns.Count Then
    ColNum = 0
  End If

End Function
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean

  ' Returns True if file exists.  Assumes path already tested.

  ' Coded by Tony Dallimore
  ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283

  If Right$(PathName, 1) <> "\" Then
    PathName = PathName & "\"
  End If
  On Error Resume Next
  FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
  On Error GoTo 0

End Function
Public Function PathExists(ByVal PathName As String) As Boolean

  ' Returns True if path exists

  ' Coded by Tony Dallimore
  ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283

  On Error Resume Next
  PathExists = ((GetAttr(PathName) And vbDirectory) = vbDirectory)
  On Error GoTo 0

End Function
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String)

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  ' Coded by Tony Dallimore

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet

  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If

  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

从多个选定的文件中复制一系列数据

2 个答案: