2001-2010中国统计年鉴，每年一个Excel文件，方便使用。每个文件中含三段用来集成文件的ＶＢ。你打开文件时可能会有ＶＢ的安全提示。

CopySheet2003()　用Excel2003版来集成文件（我把Excel文件都放在一个叫c:\temp\cb）
CopySheet2007()　用Excel2007版来集成文件（我把Excel文件都放在一个叫c:\temp\cb）
BuiltToc()                 用于建目录

如果你把文件重新命名后，目录中的链接断了的话，再运行一遍BuiltToc()就会更新目录。

以后大家拿到新的统计年鉴，用以上程序就可以自己来集成Excel文件了。

想了想，还是收一块钱吧。



Function FileList(fldr As String, Optional fltr As String = "*.xls") As Variant
    Dim sTemp As String, sHldr As String
    If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
    sTemp = Dir(fldr & fltr)
    If sTemp = "" Then
        FileList = False
        Exit Function
    End If
    Do
        sHldr = Dir
        If sHldr = "" Then Exit Do
        sTemp = sTemp & "|" & sHldr
     Loop
    FileList = Split(sTemp, "|")
End Function

Sub CopySheet2007()
Dim basebook As Workbook
Dim tmpbook As Workbook
Dim i As Long
    Application.ScreenUpdating = False

    Files = FileList("C:\temp\cb")
    ChDir "C:\temp\cb"
    Set basebook = ThisWorkbook
    For i = LBound(Files) To UBound(Files)
            Set tmpbook = Workbooks.Open("c:\temp\cb\" & Files(i))
            tmpbook.Worksheets(1).Copy after:= _
            basebook.Sheets(basebook.Sheets.Count)
            ActiveSheet.Name = Replace(tmpbook.Name, ".xls", "")
            tmpbook.Close
        Next i

    Application.ScreenUpdating = True

    'fileSaveName = Application.GetSaveAsFilename( _
    'fileFilter:="Microsoft Excel Workbook (*.xls), *.xls")

'BuiltToc
End Sub


Sub CopySheet2003()
Dim basebook As Workbook
Dim tmpbook As Workbook
Dim i As Long
    Application.ScreenUpdating = False

    With Application.FileSearch
        .NewSearch
        .LookIn = "c:\temp\cb"
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            Set basebook = ThisWorkbook
            For i = 1 To .FoundFiles.Count
                Set tmpbook = Workbooks.Open(.FoundFiles(i))
                    tmpbook.Worksheets(1).Copy after:= _
                    basebook.Sheets(basebook.Sheets.Count)
                    ActiveSheet.Name = Replace(tmpbook.Name, ".xls", "")
                tmpbook.Close
            Next i
        End If
    End With

    Application.ScreenUpdating = True

    BuiltToc
End Sub

Sub BuiltToc()
  ActiveWorkbook.Save

  Dim cSht As Long
  Dim qSht As String

  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False

  Sheets("index").Select

  Cells(1, 1) = "Sheet Name"
  Cells(1, 3) = "Table Name"

  For cSht = 2 To ActiveWorkbook.Sheets.Count
     Cells(1 + cSht, 1) = "'" & Sheets(cSht).Name
     qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
     Cells(1 + cSht, 3) = "'" & Sheets(cSht).Cells(1, 1)
     'ActiveSheet.Cells(1 + cSht, 1).Formula = "=hyperlink(""'" & qSht & "'!A1"",""" & qSht & """)"

     ActiveSheet.Cells(1 + cSht, 1).Formula = _
            "=hyperlink(""[" & ActiveWorkbook.Name _
            & "]'" & qSht & "'!A1"",""" & qSht & """)"

     Next cSht

  Rows("1:1").Select
  Selection.Font.Bold = True

  Columns("A:A").EntireColumn.AutoFit
  Columns("C:C").EntireColumn.AutoFit

  On Error Resume Next
  Application.ScreenUpdating = True
End Sub