如何提取工作簿的名称

wangzhongtu

如何将文件夹5里面的所有文件的文件名提取到B列

taller

1. Private Sub CommandButton1_Click()
   
2.     Dim myPath, myName
   
3.     myPath = ThisWorkbook.Path & "\*.xls"
   
4.     myName = Dir(myPath)
   
5.     Do While myName <> ""
   
6.         Sheet1.[b65536].End(xlUp).Offset(1, 0) = myName
   
7. ’        如果不需要当前工作簿名称，改用下面的这个代码
   
8. ‘        If myName <> ThisWorkbook.Name Then Sheet1.[b65536].End(xlUp).Offset(1, 0) = myName
   
9.         myName = Dir()
   
10.     Loop
    
11. End Sub
    

复制代码

zhaogang1960

不包含本工作簿名，请测试：
Sub Macro1()
    Dim arr(), myPath$, myFile$, m As Integer
    Application.ScreenUpdating = False
    myPath = ThisWorkbook.Path & "\"
    myFile = Dir(myPath & "*.xls")
    Do While myFile <> ""
        If myFile <> ThisWorkbook.Name Then
            m = m + 1
            ReDim Preserve arr(1 To 2, 1 To m)
            arr(1, m) = m
            arr(2, m) = Split(myFile, ".")(0)
        End If
        myFile = Dir
    Loop
    ActiveSheet.UsedRange.Offset(1, 0).ClearContents
    [a2].Resize(m, 2) = WorksheetFunction.Transpose(arr)
    Application.ScreenUpdating = True
End Sub

如饥似渴

2楼 taller  先生，您好！
    能告诉怎样使用吗？把代码放在工作表的代码区，然后重新启动工作薄，不见效果，为什么？如果能改写成一打开“工作薄。xls”就能见到效果不是更好吗？请赐教。

sincerityyyz

把代码放到工作表的Open事件中即可！

szqhb

2、3楼的方法都可以，需设置一个按钮激活宏
2楼的代码不小心激活宏会重复提取
3楼好，且有序号

高玉甫

3楼 zhaogang1960  先生，您好！
    您在凌晨还在为新手们解答问题，深为感动，我们这些新手由衷地谢谢您，并祝您中秋快乐！
    您在 3 楼写的代码我把它放到工作表的Open事件中，很好，如附件“文件夹”的“02”，这也是我长期以来想解决而没有答案的问题，谢谢您的帮助。
    但是，您在 3 楼的代码还不能完全解决我的问题，请大侠在您 3 楼代码的基础上添加几句代码，帮助我了却如下的愿望：
    1.  打开工作薄，文件夹中的工作薄就自动在“工作薄登记”的“02”中形成目录(您在3楼的代码已经实现)；
    2.  “工作薄登记”的“02”中的工作薄名称自动生成“超链接”，即，只要点击目录中某工作薄名称，这个工作薄就会自动打开。这一点要求请大侠帮忙实现，谢谢您。
    大侠实现后，请在附件中测试，并将成功的附件回传，如何，谢谢您！
    祝 zhaogang1960 先生中秋快乐，全家幸福安康！

taller

原帖由 szqhb 于 2009-10-3 09:16 发表
2、3楼的方法都可以，需设置一个按钮激活宏
2楼的代码不小心激活宏会重复提取
3楼好，且有序号

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

zhaogang1960

请测试：
Private Sub Workbook_Open()
    Dim myPath$, myFile$, m As Integer
    Application.ScreenUpdating = False
    myPath = ThisWorkbook.Path & "\"
    myFile = Dir(myPath & "*.xls")
    m = 1
    With Sheets("02")
        .UsedRange.Offset(1, 0).Clear
        Do While myFile <> ""
            If myFile <> ThisWorkbook.Name Then
                m = m + 1
                .Hyperlinks.Add Anchor:=.Cells(m, 2), Address:=myPath & myFile, TextToDisplay:=Split(myFile, ".")(0)
            End If
            myFile = Dir
        Loop
        .Range("A2").Value = 1
        If m > 2 Then .Range("A2").AutoFill Destination:=.Range("A2").Resize(m - 1), Type:=xlFillSeries
    End With
    Application.ScreenUpdating = True
End Sub

wangzhongtu

哇高手都来   光临过啦   太棒了   
有人说2楼的代码有重复   我看了下 提出问题的朋友 是这样认为的:   第一次执行命令时非常成功  ,第二次执行命令时会在原复制好的名称下面重新再复制一遍,
即点N次就会出现同一工作表名有N个