如何用excel宏在该Excel文件所在目录下创建指定文件

注意把代码前的#001这样的要去掉。我这有VBA的技巧，如果需要可以留邮箱给我。

#001 Private Sub Worksheet_Activate()
#002 Dim sh As Worksheet
#003 Dim a As Integer
#004 Dim R As Integer
#005 R = Sheet1.[A65536].End(xlUp).Row
#006 a = 2
#007 If Sheet1.Cells(2, 1) <> "" Then
#008 Sheet1.Range("A2:A" & R).ClearContents
#009 End If
#010 For Each sh In Worksheets
#011 If sh.CodeName <> "Sheet1" Then
#012 Sheet1.Cells(a, 1).Value = sh.Name
#013 a = a + 1
#014 End If
#015 Next
#016 End Sub
代码解析：
工作e79fa5e98193e4b893e5b19e330表的Activate事件，在“目录”工作表激活时自动建立工作簿中除“目录”工作表外所有工作表的目录。
第2、3、4行代码声明变量类型。
第5行代码取得A列最后非空单元格的行号。
第6行代码设置变量a的初始值为2，从A2单元格开始建立工作表目录。
第7行到第9行代码判断是否存在工作表目录，如果存在先清空原来的目录，以便更新目录。
第10行到第15代码遍历工作簿的所有工作表，将除“目录”工作表外所有工作表的名称写入到A列单元格中。
为了建立到各工作表的链接，使用工作表的SelectionChange事件，如下面的代码所示。
#001 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
#002 Dim R As Integer
#003 R = Sheet1.[A65500].End(xlUp).Row
#004 On Error Resume Next
#005 If Target.Count = 1 Then
#006 If Target.Column = 1 Then
#007 If Target.Row > 1 And Target.Row <= R Then
#008 Sheets(Target.Value).Select
#009 End If
#010 End If
#011 End If
#012 End Sub
代码解析：
工作表的SelectionChange事件，当选择A列工作表目录中工作表名称时自动选择该单元格所对应的工作表。
第5、6、7行代码限制该事件触发的条件。
第8行代码选择单元格所对应的工作表。
“目录”工作表激活后自动在A列建立工作簿中除“目录”工作表以外所有表的目录

Sub 宏建立文件夹()
'此宏用于根据已经存在的工作表“A列为1~1000，B列为公司名称”，在此文件目录下创建相应的文件夹放在“文件目录”文件夹中
Dim X As Integer, ZM As String, MM As String, LJ As String, P As String, MX As String

ZM = "文件目录"

LJ = ThisWorkbook.Path '当前文档的路径

P = LJ & "\" & ZM

If Dir(P, vbDirectory) <> "" Then
MsgBox "文件夹存在，请删除"

Else

MsgBox "文件夹不存在!,系统将创建一个名为" & "的文件夹"
MkDir P
Shell "EXPLORER.EXE " & P '打开文件夹《e799bee5baa6e997aee7ad94e59b9ee7ad94333文件目录》
For X = 4 To 1000
ZM = "文件目录"
MM = Cells(X, 2)
LJ = ThisWorkbook.Path
P = LJ & "\" & ZM
MX = P & "\" & MM
If Cells(X, 1) = "" Then GoSub 100
MkDir MX '创建明细文件夹

Next X
End If
第一步、用宏3.0取出各工作表百的名称，方法：
Ctrl+F3出现自定义名称对度话框，取名为X，在“引用位置”框中输入：
=MID(GET.WORKBOOK(1),FIND("]",GET.WORKBOOK(1))+1,100)
确定知

第二步、用HYPERLINK函数批量道插入连接，方法：
在目录工作表（一般为第一回个sheet）的A2单元格输入公式：=HYPERLINK("#'"&INDEX(X,ROW())&"'!A1",INDEX(X,ROW()))
将公式向下填充答，直到出错为止，目录就生成了。

使用VBA功能，可以轻松实现，代码如下：可以提取和代码所在的zdExcel文件同目录下的所有文件名，依次在A列的单元格列出。

Sub 提取文版件权清单()
Dim k As Integer
Dim MyName As String
Dim MyPath As String
MyPath = ThisWorkbook.Path
MyName = Dir(Range("a1") & "\", vbDirectory)
Range("A2:A999").ClearContents
k = 1
Do While MyName <> ""
k = k + 1
Range("A" & k) = MyName
MyName = Dir
Loop
If k > 1 Then
MsgBox "已成功提取 " & k - 1 & " 个文件名。", vbOKOnly, "提示"
Else
MsgBox "Data文件夹内没有文件！" , vbOKOnly + vbExclamation, "提示"
End If
End Sub