• 袁家军:坚定不移打赢新时代禁毒人民战争 2019-10-15
  • 微软 Build 大会开幕;比尔盖茨大赞苹果;Drive.AI 自动驾驶服务落地 雷锋早报 2019-10-15
  • 荷兰音乐节巴士冲撞人群事件致1死3伤 肇事者自首 2019-10-03
  • 互联网新闻信息服务许可证 2019-09-20
  • 谈具体的吧,别装模作样了。客观事实与观察事实、科学事实有什么不同? 2019-09-13
  • 中国女排7小花争艳!谁能制造惊喜 一位置别拖后腿 2019-09-10
  • 女子车上突然发病 公交车长现场急救 2019-08-29
  • 英才聚神州 奋斗正当时 2019-08-29
  • 纪录电影《盲行者》入围第21届上海电影节金爵奖 2019-08-22
  • 高清:江西南昌志愿者爱心陪伴特殊儿童 2019-08-15
  • “新时代 新梦想”网络媒体新春走基层 2019-08-15
  • 国内 —频道 春城壹网 七彩云南 一网天下 2019-08-13
  • 阿呆,那是你家远祖啊,还不跪拜?[哈哈] 2019-08-11
  • 本帖关键部分已被残酷删除。 2019-08-11
  • 换一种方式吃鸡肉 美味又易做-美食资讯 2019-08-07
  • 白小姐资料一肖中特马133期

    excel利用VBA获取文件夹中的文件列表

    时间:2012-07-19 22:03来源:Office教程学习网 白小姐资料一肖中特马133期 www.yzzcc.tw编辑:麦田守望者

    白小姐资料一肖中特马133期 www.yzzcc.tw 如果我们要在Excel中获取某个文件夹中所有的文件列表,可以通过下面的VBA代码来进行。代码运行后,首先弹出一个浏览文件夹对话框,然后新建一个工作簿,并在工作表的A至F列分别列出选定文件夹中的所有文件的文件名、文件大小、创建时间、修改时间、访问时间及完整路径。方法如下:

    1.按Alt+F11,打开VBA编辑器,单击菜单“插入→???rdquo;,将下面的代码粘贴到右侧的代码窗口中:

    Sub GetFileList()
    Dim strFolder As String
    Dim varFileList As Variant
    Dim FSO As Object, myFile As Object
    Dim myResults As Variant
    Dim l As Long
    '显示打开文件夹对话框
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    If .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹
    strFolder = .SelectedItems(1)
    End With
    '获取文件夹中的所有文件列表
    varFileList = fcnGetFileList(strFolder)
    If Not IsArray(varFileList) Then
    MsgBox "未找到文件", vbInformation
    Exit Sub
    End If
    '获取文件的详细信息,并放到数组中
    ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)
    myResults(0, 0) = "文件名"
    myResults(0, 1) = "大?。ㄗ纸冢?quot;
    myResults(0, 2) = "创建时间"
    myResults(0, 3) = "修改时间"
    myResults(0, 4) = "访问时间"
    myResults(0, 5) = "完整路径"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For l = 0 To UBound(varFileList)
    Set myFile = FSO.GetFile(strFolder & "\" & CStr(varFileList(l)))
    myResults(l + 1, 0) = CStr(varFileList(l))
    myResults(l + 1, 1) = myFile.Size
    myResults(l + 1, 2) = myFile.DateCreated
    myResults(l + 1, 3) = myFile.DateLastModified
    myResults(l + 1, 4) = myFile.DateLastAccessed
    myResults(l + 1, 5) = myFile.Path
    Next l
    fcnDumpToWorksheet myResults
    Set myFile = Nothing
    Set FSO = Nothing
    End Sub

    Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant
    ' 将文件列表放到数组
    Dim f As String
    Dim i As Integer
    Dim FileList() As String
    If strFilter = "" Then strFilter = "*.*"
    Select Case Right(strPath, 1)
    Case "\", "/"
    strPath = Left(strPath, Len(strPath) - 1)
    End Select
    ReDim Preserve FileList(0)
    f = Dir(strPath & "\" & strFilter)
    Do While Len(f) > 0
    ReDim Preserve FileList(i) As String
    FileList(i) = f
    i = i + 1
    f = Dir()
    Loop
    If FileList(0) <> Empty Then
    fcnGetFileList = FileList
    Else
    fcnGetFileList = False
    End If
    End Function
    Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
    Dim iSheetsInNew As Integer
    Dim sh As Worksheet, wb As Workbook
    Dim myColumnHeaders() As String
    Dim l As Long, NoOfRows As Long
    If mySh Is Nothing Then
    '新建一个工作簿
    iSheetsInNew = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set wb = Application.Workbooks.Add
    Application.SheetsInNewWorkbook = iSheetsInNew
    Set sh = wb.Sheets(1)
    Else
    Set mySh = sh
    End If
    With sh
    Range(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)) = varData
    .UsedRange.Columns.AutoFit
    End With
    Set sh = Nothing
    Set wb = Nothing
    End Sub

    2.关闭VBA编辑器,回到Excel工作表中,按Alt+F8,打开“宏”对话框,选择“GetFileList”,单击“运行”按钮。

    ------分隔线----------------------------
    标签(Tag):excel excel2007 excel2010 excel2003 excel技巧 excel教程 excel实例教程 excel2010技巧
    ------分隔线----------------------------
    推荐内容
    猜你感兴趣
  • 袁家军:坚定不移打赢新时代禁毒人民战争 2019-10-15
  • 微软 Build 大会开幕;比尔盖茨大赞苹果;Drive.AI 自动驾驶服务落地 雷锋早报 2019-10-15
  • 荷兰音乐节巴士冲撞人群事件致1死3伤 肇事者自首 2019-10-03
  • 互联网新闻信息服务许可证 2019-09-20
  • 谈具体的吧,别装模作样了。客观事实与观察事实、科学事实有什么不同? 2019-09-13
  • 中国女排7小花争艳!谁能制造惊喜 一位置别拖后腿 2019-09-10
  • 女子车上突然发病 公交车长现场急救 2019-08-29
  • 英才聚神州 奋斗正当时 2019-08-29
  • 纪录电影《盲行者》入围第21届上海电影节金爵奖 2019-08-22
  • 高清:江西南昌志愿者爱心陪伴特殊儿童 2019-08-15
  • “新时代 新梦想”网络媒体新春走基层 2019-08-15
  • 国内 —频道 春城壹网 七彩云南 一网天下 2019-08-13
  • 阿呆,那是你家远祖啊,还不跪拜?[哈哈] 2019-08-11
  • 本帖关键部分已被残酷删除。 2019-08-11
  • 换一种方式吃鸡肉 美味又易做-美食资讯 2019-08-07
  • 二个骰子单双怎么玩 彩票软件论坛 即时比分大赢家体育 重庆时时历史开奖记录 泰山计划安卓版 微信如何购买福利彩票 欢乐生肖时时彩走势图 6码复式二中二共几组 重庆时时彩苹果版免费 玩网络彩票怎样才能稳赚