批量超链接批量合并拆分excel工作表

批量链接

首先新建一个目录页工作表，然后按下Ctrl+F3键，调出自定义名称对话框，取名为X，在“引用位置”框中输入：

=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1))+1,100) ，确定。然后用HYPERLINK函数批量插入连接，方法是：在目录页工作表，比如A2单元格输入公式：

=HYPERLINK("#'"&INDEX(X,ROW())&"'!A1",INDEX(X,ROW())) ，拖动填充柄，将公式向下填充，直到出错为止，目录就生成了。

利用以上两种方法都可以实现工作表间的关联链接。为了更加方便，也可以在除了目录页的其余工作表，制作一个返回目录的超链接。

如果是工作表，可以用下面的代码实现。

假设目录放在sheet1的A列，从A1依次向下排列。

右击sheet1标签》查看代码》将第一段代码粘贴进去后按F5运行

再将第2段代码贴进去

单击A列任意单元格，就会跳转到对应工作表中。

Sub 添加工作表()

On Error Resume Next

Dim a()

E = [a65536].End(xlUp).Row

a = Range("a1:a" & E).Value

For r = 1 To E

Application.Sheets.Add

= a(r, 1)

Next

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

With Target

If .Cells.Count > 1 Then Exit Sub

If .Column > 1 Then Exit Sub

Sheets(.Value).Select

End With

End Sub

批量合并工作表，前提是将待合并的工作表放入同一文件夹中

Sub 合并()

Dim FilesToOpen

Dim x As Integer

On Error GoTo ErrHandler

Application.ScreenUpdating = False

FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.xls), *.xls", MultiSelect:=True, Title:="要合并的文件")

If TypeName(FilesToOpen) = "Boolean" Then

MsgBox "没有选中文件"

GoTo ExitHandler

End If

x = 1

While x <= UBound(FilesToOpen)

Workbooks.Open Filename:=FilesToOpen(x)

Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) x = x + 1

Wend

ExitHandler:

Application.ScreenUpdating = True

Exit Sub

ErrHandler:

MsgBox Err.Description

Resume ExitHandler

End Sub

第二种命令

Sub 合并()

Application.ScreenUpdating = False

Application.EnableEvents = False

MyPath = ActiveWorkbook.Path

ActiveName =

MyName = Dir(MyPath & "\" & "*.xls")

i = 0

Do While MyName <> ""

If MyName <> ActiveName Then

Set Wb = Workbooks.Open(MyPath & "\" & MyName)

i = i + 1

With Workbooks(1).ActiveSheet

For j = 1 To Sheets.Count

Wb.Sheets(j).Copy before:=Workbooks(ActiveName).Sheets(1)

Next

Wbn = Wbn & Chr(13) &

Wb.Close False

End With

End If

MyName = Dir

Loop

MsgBox "共合并了" & i & "个工作薄,如下:" & Chr(13) & Wbn, , "工作簿合并" Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub

批量拆分工作薄

Sub SaveSeparately()

Dim sht As Worksheet

Application.ScreenUpdating = False

ipath = ThisWorkbook.Path & "\"

For Each sht In Sheets

sht.Copy

ActiveWorkbook.SaveAs ipath & & ".xls"

ActiveWorkbook.Close

Next

Application.ScreenUpdating = True

End Sub