如何提取工作簿的名称

szqhb

原帖由 taller 于 2009-10-3 09:37 发表


能否仔细说说为什么2楼代码会重复提取吗？

我不知道是什么原因
再次激活你给的宏，提取的目录会叠加在前面提取的后面

高玉甫

我认为，这个问题还是要讨论讨论的，即使我有了如上各楼的答案。

zhaogang1960

这个问题不用讨论了，版主给出的是基本思路，如果要再次导入需要清除原数据，在写数据语句之前加上一句：
ActiveSheet.UsedRange.Offset(1, 0).ClearContents'删除表头下面所有数据

高玉甫

经过测试，您在23楼的添加代码很好，解决了上述讨论的问题，谢谢您的指教。

yj0715

赵老师，谢谢您百忙中给于解答。
测试有两个问题：
1.如果将程序表放到其他目录下面执行，不能删除已生成文件清单的旧有工作表而只保留总目录一表和当前目录下文件清单工作表。
2.如果当前目录下面子目录下面还有子目录就无法生成其中的文件清单。当然这个要实现就得改现在的工作薄结构。暂时没想到好的办法。
请赵老师先帮忙解决第一个问题，谢谢！

[ 本帖最后由 yj0715 于 2009-10-6 19:39 编辑 ]

高玉甫

zhaogang1960  先生，您好！
    您在 15 楼写的代码太棒了，神奇之极！
    不过，在使用过程中，我又有新的想法，还想请您再把代码优化一下，可以吗？
    在实际工作中，公司有 8 个文件夹，这些文件夹都需要建立各自的文件目录，如果按照15楼的代码去做，这8个文件目录是8个工作薄，且这8个工作薄分别存放在这8个文件夹内，这样查阅文件还是有点麻烦(人心不足)，因此，我有如下想法：
    在这8个文件夹之外设置一个“文件目录”工作薄，其中，Sheet1是文件夹 A 的文件目录，Sheet2是文件夹 B 的文件目录，Sheet3是文件夹 C 的文件目录，Sheet4是文件夹 D 的文件目录，............。
    这样，我只要打开“文件目录”这个工作薄，公司的所有文件就可“尽收眼底”，只要点击我要想要的文件名称，这个文件就会“唰”地一下打开！哇！那是多么神奇！............
       zhaogang1960  先生，我这不是异想天开吧？听别人说，“只有人想不到的，没有 VBA  实现不了的”，我想，我的这个想法在您的笔下也一定能够实现！
    朋友，在您 15 楼代码的基础上，请您再加几句代码，帮我实现我的梦想吧，谢谢您了。

zhaogang1960

请上传个附件吧，根据附件写出来可能会更切合实际些

lhw8432037

LZ真是“非常谦虚”的人呀，不过也该自己动动手吧。
高手不是义工，只要给咱们这些请求答案的人指出个思路，然后剩下的，让咱们自个研究、动手，这样才有意义，如果凡事都来个现成的，多没有意思呀。

zhaogang1960

没有附件和要求的效果，只有猜着写了，请测试：
Private Sub Workbook_Open()
    Dim mypath$, myfile$, mydir$, arr() As String, m%, n%, i%, sh As Worksheet, a
    a = Array("序号", "文件名", "日期")
    Application.ScreenUpdating = False
    mypath = ThisWorkbook.Path & "\"
    mydir = Dir(mypath & "*", vbDirectory)
    While mydir > ""
        If Not mydir Like ".*" And GetAttr(mypath & mydir) = vbDirectory Then
            n = n + 1
            ReDim Preserve arr(1 To 2, 1 To n)
            arr(1, n) = mypath & mydir & "\"
            arr(2, n) = mydir
        End If
        mydir = Dir()
    Wend
    On Error Resume Next
    For i = 1 To n
        Set sh = Sheets(arr(2, i))
        If sh Is Nothing Then
            With Sheets.Add(After:=Sheets(Sheets.Count))
                .Name = arr(2, i)
                .Range("a1").Resize(1, 3) = a
            End With
        End If
        Set sh = Nothing
        myfile = Dir(arr(1, i) & "*.*")
        m = 1
        With Sheets(arr(2, i))
            .UsedRange.Offset(1, 0).Clear
            Do While myfile <> ""
                    m = m + 1
                    .Hyperlinks.Add Anchor:=.Cells(m, 2), Address:=arr(1, i) & myfile, TextToDisplay:=Split(myfile, ".")(0)
                myfile = Dir
            Loop
            .Range("A2").Value = 1
            If m > 2 Then .Range("A2").AutoFill Destination:=.Range("A2").Resize(m - 1), Type:=xlFillSeries
            .Range("C2").Resize(m - 1) = Date
        End With
    Next
    Sheets(1).Activate
    Application.ScreenUpdating = True
End Sub
不好意思，多处错误，只好重新编辑了

[ 本帖最后由 zhaogang1960 于 2009-10-5 23:45 编辑 ]

高玉甫

28楼 zhaogang1960  先生，您好！
    看到您深夜还在为我解答问题，很是感动，您这种诲人不倦的教学精神，值得我们学习。
    您在 28 楼的代码我进行了测试，不通。我也试图对它进行重新编辑，怎奈我基础太差，几番周折也没能把它理顺，惭愧。
    我将附件上传过去，请您参看我在 25 楼的叙述，把您在 28 楼的代码修整一下，测试成功后再把附件回传给我，谢谢您了，大侠。