Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2255|回复: 5

[已解决]VBA代码修改求助

[复制链接]
发表于 2017-5-27 20:08 | 显示全部楼层 |阅读模式
本帖最后由 安全网 于 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盘内的新建文件夹内的工作薄的名称

最佳答案
2017-5-27 20:31
fp = "D:\新建文件夹"
你试下。
发表于 2017-5-27 20:31 | 显示全部楼层    本楼为最佳答案   
fp = "D:\新建文件夹"
你试下。
回复

使用道具 举报

 楼主| 发表于 2017-5-28 11:55 | 显示全部楼层
大灰狼1976 发表于 2017-5-27 20:31
fp = "D:\新建文件夹"
你试下。

说图纸没有过错怎么修改
QQ图片20170528115505.png
回复

使用道具 举报

发表于 2017-5-28 12:00 | 显示全部楼层
不知道你的Brr(2,i)是什么,甚至不知道你的r变量是什么,从哪里来的。抱歉
回复

使用道具 举报

 楼主| 发表于 2017-5-28 12:32 | 显示全部楼层
大灰狼1976 发表于 2017-5-28 12:00
不知道你的Brr(2,i)是什么,甚至不知道你的r变量是什么,从哪里来的。抱歉

          ReDim Preserve Brr(1 To 2, 1 To r)
            Brr(1, r) = fp
            Brr(2, r) = fm
这里来的
回复

使用道具 举报

 楼主| 发表于 2017-5-28 13:46 | 显示全部楼层
安全网 发表于 2017-5-28 12:32
ReDim Preserve Brr(1 To 2, 1 To r)
            Brr(1, r) = fp
            Brr(2, r) =  ...


Private Sub UserForm_Initialize()
Dim fp$
fp = "D:\标准数据库\"
Call searfile(fp, ".xls")
[a1].Resize(r, 1) = Application.Transpose(Arr1)
End Sub

Sub searfile(fp As String, fkey As String)
Dim fm, r&
If Right(fp, 1) <> "" Then fp = fp & ""
If Len(fkey) < 1 Then fkey = ".xls"
fm = Dir(fp, vbDirectory)
Do While fm <> ""
    If fm <> "." And fm <> ".." Then
        If InStr(fm, fkey) Then
            r = r + 1
            ReDim Preserve Arr1(1 To r)
            Arr1(r) = fp & fm
        End If
    End If
    fm = Dir
Loop
End Sub
求助将文件夹内的工作薄名称写入Me.ComboBox1.AddItem 的VBA代码修正

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 20:41 , Processed in 0.980681 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表