本帖最后由 安全网 于 2017-5-28 15:46 编辑
Private Sub UserForm_Initialize()
Dim fp$
fp = ThisWorkbook.Path & "D:\新建文件夹"
Call searfile(fp, ".xls")
For i = 1 To r
If Brr(2, i) <> ThisWorkbook.Name Then
Me.ComboBox1.AddItem Brr(2, i)
End If
Next
End Sub
Sub searfile(fp As String, fkey As String)
Dim Arr1() As String, i1 As Integer, i2 As Integer, fm
If Right(fp, 1) <> "\" Then fp = fp & "\"
If Len(fkey) < 1 Then fkey = ".xlsx" '文件类型省略则仅搜索.xls文件
fm = Dir(fp, vbDirectory)
Do While fm <> ""
If fm <> "." And fm <> ".." Then
If (GetAttr(fp & fm) And vbDirectory) = vbDirectory Then
i1 = i1 + 1
ReDim Preserve Arr1(1 To i1)
Arr1(i1) = fp & fm
End If
If Right(fm, Len(fkey)) = fkey Then
r = r + 1
ReDim Preserve Brr(1 To 2, 1 To r)
Brr(1, r) = fp
Brr(2, r) = fm
End If
End If
fm = Dir
Loop
For i2 = 1 To i1
Call searfile(Arr1(i2), fkey)
Next
End Sub
求助修改为提取D盘内的新建文件夹内的工作薄的名称
|