[已解决]请求赐教！提取工作表表签并 ...

松儿

请求赐教！提取工作表表签并作链接.rar (15.93 KB, 下载次数: 16)

2013-3-29 22:16 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2013-3-29 23:07

Sub 按钮1_Click()
    Dim p, f, i, j, wk1, sh1, wk2, sh2
    Application.ScreenUpdating = False

    Set wk1 = ThisWorkbook
    Set sh1 = wk1.Sheets(1)
    sh1.Range("a2:b5555").Clear
    p = wk1.Path & "\"
    f = Dir(p)
    i = 2
    j = 1

    Do While f <> ""
        If f <> wk1.Name Then
            sh1.Cells(i, 1) = Left(f, Len(f) - 4)
            sh1.Hyperlinks.Add Anchor:=sh1.Cells(i, 1), Address:=p & f
            Set wk2 = Workbooks.Open(p & f)
            With wk2
                For Each sh2 In .Sheets
                    j = j + 1
                    sh1.Cells(j, 2) = sh2.Name
                    sh2.Hyperlinks.Add Anchor:=sh1.Cells(j, 2), Address:=p & f, SubAddress:="#" & sh2.Name & "!a1"
                Next sh2
                .Close 0
            End With
            i = j
        End If
        f = Dir
    Loop
End Sub

跳转到最佳答案楼层

爱疯

Sub 按钮1_Click()
    Dim p, f, i, j, wk, sh
    Application.ScreenUpdating = False

    Range("a2:b5555").ClearContents
    p = ThisWorkbook.Path & "\"
    f = Dir(p)
    i = 2
    j = 1

    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Cells(i, 1) = Left(f, Len(f) - 4)
            Set wk = Workbooks.Open(p & f)
            With wk
                For Each sh In .Sheets
                    j = j + 1
                    ThisWorkbook.Sheets(1).Cells(j, 2) = sh.Name
                Next sh
                .Close 0
            End With
            i = j
        End If
        f = Dir
    Loop
End Sub

松儿

爱疯 发表于 2013-3-29 22:43
Sub 按钮1_Click()
    Dim p, f, i, j, wk, sh
    Application.ScreenUpdating = False

工作表表签名称已成功获取。请做个链接。

爱疯

Sub 按钮1_Click()
    Dim p, f, i, j, wk1, sh1, wk2, sh2
    Application.ScreenUpdating = False

    Set wk1 = ThisWorkbook
    Set sh1 = wk1.Sheets(1)
    sh1.Range("a2:b5555").Clear
    p = wk1.Path & "\"
    f = Dir(p)
    i = 2
    j = 1

    Do While f <> ""
        If f <> wk1.Name Then
            sh1.Cells(i, 1) = Left(f, Len(f) - 4)
            sh1.Hyperlinks.Add Anchor:=sh1.Cells(i, 1), Address:=p & f
            Set wk2 = Workbooks.Open(p & f)
            With wk2
                For Each sh2 In .Sheets
                    j = j + 1
                    sh1.Cells(j, 2) = sh2.Name
                    sh2.Hyperlinks.Add Anchor:=sh1.Cells(j, 2), Address:=p & f, SubAddress:="#" & sh2.Name & "!a1"
                Next sh2
                .Close 0
            End With
            i = j
        End If
        f = Dir
    Loop
End Sub