本帖最后由 dshilunls 于 2013-12-16 11:36 编辑
各位老大：用EXCEL产生文件的目录清单，从网站中找了高手制作的EXCEL表格，附件是比较适合我需求的类型（我要选中文件夹内的所有文件及文件夹清单，但不要子文件夹内的内容），但使用中发现：文件地址字符大于255个时，该表格会出错。 请教各位老大，如何修改才能使目录产生不受地址字符数的影响（我可以不需要在目录表中产生文件链接）？
多谢多谢！
出错时调试页面如下：（共2个模块）
第一个模块：A通用模块Option Explicit Public MyPath AsString PublicFilesList() As String, PathsList() As String Public FilesNumAs Long, PathsNum As Long Public SubGetLists(MyPath, PathsList, PathsNum, FilesList, FilesNum) '该通用程序可提取当前文件所在目录下的所有目录名和文件名 '并提取所有文件夹名称至PathsList()数组，所有文件名至FilesList()数组 Dim MyName As String Dim i As Long, j As Long '确定文件夹及文件的数目 MyName = Dir(MyPath, vbDirectory) ' 找寻第一项。 PathsNum = 0 FilesNum = 0 Do While MyName <> "" ' 开始循环。 ' 跳过当前的目录及上层目录。 If MyName <> "." AndMyName <> ".." Then ' 使用位比较来确定 MyName 代表一目录。 If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectoryThen PathsNum = PathsNum + 1 ReDim Preserve PathsList(1 ToPathsNum) PathsList(PathsNum) = MyName Else FilesNum = FilesNum + 1 ReDim Preserve FilesList(1 ToFilesNum) FilesList(FilesNum) = MyName End If End If MyName = Dir ' 查找下一个目录。 Loop End Sub Public FunctionSplitPath(FullPath As String, ResultFlag As Integer) As String '获取路径、文件名、扩展名 'ResultFlag=0 获取路径 'ResultFlag=1 获取文件名 'ResultFlag=2 获取扩展名 Dim SplitPos As Integer, DotPos As Integer SplitPos = InStrRev(FullPath,"\") DotPos = InStrRev(FullPath, ".") Select Case ResultFlag Case 0 SplitPath = Left(FullPath, SplitPos- 1) Case 1 If DotPos = 0 Then DotPos =Len(FullPath) + 1 SplitPath = Mid(FullPath, SplitPos+ 1, DotPos - SplitPos - 1) Case 2 If DotPos = 0 Then DotPos =Len(FullPath) SplitPath = Mid(FullPath, DotPos) Case Else Err.Raise vbObjectError + 1,"SplitPath Function", "Invalid Parameter!" End Select End Function
第二个模块：B自动生成表格
Option Explicit Sub AutoWriteRecord()
Dim ThisWorkbook As Workbook, ThisWorksheet As Worksheet
Dim CreatingRange As Range, DataRange As Range, CreatingArray() As Variant
Dim i As Long, j As Long, k As Long, TotalNum As Long
Dim MyFormat As String
'设置屏幕不可更新，该语句可节约部分程序运行的时间
Application.ScreenUpdating = False
'设置Excel中的公式计算为手动重算，因该工作簿数据计算较多，可节约大量的程序运行时间，经笔者测试大约节约100倍左右
Application.Calculation = xlManual
'从B2获取文件夹目录，若没有目录，则取当前活动工作薄所在目录，并写入到B2单元格
Set ThisWorkbook = ActiveWorkbook
Set ThisWorksheet = ThisWorkbook.Worksheets("一览表")
If ThisWorksheet.Range("B2").Value <> "" Then
MyPath = ThisWorksheet.Range("B2").Value
Else
MyPath = ThisWorkbook.Path
ThisWorksheet.Range("B2").Value = MyPath
End If
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'调用子程，返回目录下的所有文件夹及文件列表
Call GetLists(MyPath, PathsList, PathsNum, FilesList, FilesNum)
'生成表格数据
TotalNum = Application.WorksheetFunction.Max(PathsNum + FilesNum, 1)
ReDim CreatingArray(1 To TotalNum, 1 To 4)
Set CreatingRange = Range("A4").Resize(TotalNum, 4)
Set DataRange = Application.Intersect(ThisWorksheet.Rows("4:1000"), ThisWorksheet.UsedRange)
DataRange.ClearContents
k = 0
MyFormat = ThisWorksheet.Range("E2").Value
Select Case MyFormat
Case "所有项目"
For i = 1 To PathsNum
k = k + 1
CreatingArray(k, 1) = k
CreatingArray(k, 2) = "文件夹"
CreatingArray(k, 3) = PathsList(i)
CreatingArray(k, 4) = "=hyperlink(" & Chr(34) & MyPath & PathsList(i) & Chr(34) & _
"," & Chr(34) & "查看文件夹" & Chr(34) & ")"
Next i
For j = 1 To FilesNum
k = k + 1
CreatingArray(k, 1) = k
CreatingArray(k, 2) = "文件"
CreatingArray(k, 3) = FilesList(j)
CreatingArray(k, 4) = "=hyperlink(" & Chr(34) & MyPath & FilesList(j) & Chr(34) & _
"," & Chr(34) & "查看文件" & Chr(34) & ")"
Next j
Case "文件夹"
For i = 1 To PathsNum
k = k + 1
CreatingArray(k, 1) = k
CreatingArray(k, 2) = "文件夹"
CreatingArray(k, 3) = PathsList(i)
CreatingArray(k, 4) = "=hyperlink(" & Chr(34) & MyPath & PathsList(i) & Chr(34) & _
"," & Chr(34) & "查看文件夹" & Chr(34) & ")"
Next i
Case "文件"
For j = 1 To FilesNum
k = k + 1
CreatingArray(k, 1) = k
CreatingArray(k, 2) = "文件"
CreatingArray(k, 3) = FilesList(j)
CreatingArray(k, 4) = "=hyperlink(" & Chr(34) & MyPath & FilesList(j) & Chr(34) & _
"," & Chr(34) & "查看文件" & Chr(34) & ")"
Next j
Case Else
For j = 1 To FilesNum
If MyFormat = Right(FilesList(j), Len(MyFormat)) Then
k = k + 1
CreatingArray(k, 1) = k
CreatingArray(k, 2) = "文件"
CreatingArray(k, 3) = Left(FilesList(j), Len(FilesList(j)) - Len(MyFormat))
CreatingArray(k, 4) = "=hyperlink(" & Chr(34) & MyPath & FilesList(j) & Chr(34) & _
"," & Chr(34) & "查看文件" & Chr(34) & ")"
End If
Next j
End Select
CreatingRange = CreatingArray '设置“屏幕更新”可用及“公式计算”选项为自动重算
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub Sub AutoCreatList() Dim ThisWorkbook As Workbook, ThisWorksheet As Worksheet
Dim FileForm As String
Dim i As Integer, j As Integer, k As Integer
'设置屏幕不可更新，该语句可节约部分程序运行的时间
Application.ScreenUpdating = False
'设置Excel中的公式计算为手动重算，因该工作簿数据计算较多，可节约大量的程序运行时间，经笔者测试大约节约100倍左右
Application.Calculation = xlManual
'从B2获取文件夹目录，若没有目录，则取当前活动工作薄所在目录，并写入到B2单元格
Set ThisWorkbook = ActiveWorkbook
Set ThisWorksheet = ThisWorkbook.Worksheets("一览表")
If ThisWorksheet.Range("B2").Value <> "" Then
MyPath = ThisWorksheet.Range("B2").Value
Else
MyPath = ThisWorkbook.Path
ThisWorksheet.Range("B2").Value = MyPath
End If
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
'调用子程，返回目录下的所有文件夹及文件列表
Call GetLists(MyPath, PathsList, PathsNum, FilesList, FilesNum)
FileForm = "所有项目,文件夹,文件"
k = 0
For i = 1 To UBound(FilesList)
For j = i To UBound(FilesList)
If SplitPath(FilesList(i), 2) = SplitPath(FilesList(j), 2) Then k = k + 1
If k = 2 Then GoTo 100
Next j
If k = 1 Then FileForm = FileForm & "," & SplitPath(FilesList(i), 2)
100:
k = 0
Next i
With ThisWorksheet.Range("E2").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=FileForm
End With
'设置“屏幕更新”可用及“公式计算”选项为自动重算
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic End Sub
| 
IP卡
狗仔卡
发表于 2013-12-15 15:10
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
抢沙发
千斤顶
显身卡
发表于 2013-12-15 22:31
楼主
。