问与答93：如何将工作簿中引用的文件全部复制并汇总到指定文件夹中？

Q：我在做一个非常巨大的数据，一个主工作簿，还有非常多个被引用数据的工作簿散布在计算机的很多位置。因为很多数据是临时来的，时间一长，我已经搞不清到底引用了哪些工作簿，有没有办法自动把相关工作簿打包在一起？

A：这只能使用VBA来解决了。

例如下图1所示，在工作簿的工作表Sheet1中有几个单元格分别引用了不同位置工作簿中的数据，我们要把引用的这几个工作簿复制到该工作簿所在的文件夹中。

图1

可以使用下面的VBA代码：

Sub CopyFiles()

Dim rng As Range

Dim rngFormulas As Range

Dim wks As Worksheet

Dim strFind1 As String

Dim iPos1 As Integer

Dim strFind2 As String

Dim iPos2 As Integer

Dim strPath As String

Dim strFile As String

'设置工作表且将该工作表中的公式单元格赋给变量

Set wks = Worksheets("Sheet1")

Set rngFormulas =wks.UsedRange.SpecialCells(xlCellTypeFormulas)

'查找的字符

strFind1 = "\"

strFind2 = "]"

For Each rng In rngFormulas

'确定文件路径

iPos1 = iPos(rng.Formula, strFind1)

If iPos1 = 0 Then

strPath = ""

Else

strPath = Mid(rng.Formula, 3, iPos1- 2)

End If

'确定文件名

iPos2 = iPos(rng.Formula, strFind2)

If iPos2 = 0 Then

strFile = ""

Else

strFile = Mid(rng.Formula, iPos1 +2, iPos2 - iPos1 - 2)

End If

'如果找到且不在当前工作簿文件夹

'则将文件复制到当前文件夹

If strPath <> "" AndstrFile <> "" And strPath <> ThisWorkbook.Path &"\" Then

FileCopy strPath & strFile,ThisWorkbook.Path & "\" & strFile

End If

Next rng

End Sub

'查找字符位置

Function iPos(MyString As String, strFind As String) As Integer

Dim lLength As Long

lLength = Len(MyString)

iPos = InStrRev(MyString, strFind)

End Function

碰到这种情况的朋友，可以试试看。