注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

Mr.Right

不顾一切的去想,于是我们有了梦想。脚踏实地的去做,于是梦想成了现实。

 
 
 

日志

 
 
关于我

人生一年又一年,只要每年都有所积累,有所成长,都有那么一次自己认为满意的花开时刻就好。即使一时不顺,也要敞开胸怀。生命的荣枯并不是简单的重复,一时的得失不是成败的尺度。花开不是荣耀,而是一个美丽的结束,花谢也不是耻辱,而是一个低调的开始。

网易考拉推荐

阿英讲VBA遍历文件夹及子文件夹内的TXT文件  

2015-10-08 23:13:15|  分类: 编程 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
即以此功德,庄严佛净土。上报四重恩,下济三途苦。惟愿见闻者,悉发菩提心。在世富贵全,往生极乐国。
Sub TraverseSubfolder()
    ' (1) traverse each subfolder in the given directory
    Dim fso, fDirectory, fs, f
    Dim strDataDirectory As String
    Dim i As Integer
    ActiveSheet.Range("A" & 1) = "Folder Name"
    ActiveSheet.Range("B" & 1) = "Folder Size/KB"
    
    strDataDirectory = "D:\sources\demo"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fDirectory = fso.GetFolder(strDataDirectory)
    Set fsubfolders = fDirectory.SubFolders
   
    i = 2
    For Each folder In fsubfolders
        Debug.Print "Folder Size: "; folder.Name, Format(folder.Size, "#.####") & "Bytes"
        ActiveSheet.Range("A" & i) = folder.Name
        ActiveSheet.Range("B" & i) = folder.Size / 1024
        i = i + 1
    Next
    
    ActiveSheet.UsedRange.Rows.AutoFit
    ActiveSheet.UsedRange.Columns.AutoFit
    
    ' (2) traverse each txt files in the current directory
    Dim filesInCurrFolder
    Set filesInCurrFolder = fDirectory.Files
    ' traverse each file in the the current directory
    ActiveSheet.Range("D" & 1) = "当前文件夹文件列表fso"
    
    i = 2
    For Each file In filesInCurrFolder
        Debug.Print file
        Debug.Print "TypeName = " & TypeName(file)
        ActiveSheet.Range("D" & i) = file
        i = i + 1
    Next
    
    ' traverse each txt file in the the current directory
    ActiveSheet.Range("E" & 1) = "当前文件夹txt文件列表"
    i = 2
    For Each file In filesInCurrFolder
        If InStr(LCase(file.Name), "txt") Then '用instr方法比对文件名称是否包含指定字符
            Debug.Print file
            Debug.Print "TypeName = " & TypeName(file)
            ActiveSheet.Range("E" & i) = file
            i = i + 1
        End If
    Next
    
    ' (3) traverse each txt files in the current directory using DIR
    Dim currentFile As String
    Dim s As String
    Dim count As Integer
    ActiveSheet.Range("C" & 1) = "当前文件夹文件列表DIR"
    currentFile = Dir(strDataDirectory & "\*.txt")
    'find the 1st txt file in the current folder
    count = 1        ' the number of txt files
    ActiveSheet.Range("C" & count + 1) = strDataDirectory & currentFile
    s = s & count & "、" & currentFile
    Do While currentFile <> ""
        currentFile = Dir        ' find the next txt file
        If currentFile = "" Then
            Exit Do         ' the traverse task finishes
        End If
        count = count + 1
        ActiveSheet.Range("C" & count + 1) = strDataDirectory & currentFile
        If count Mod 2 <> 1 Then
            s = s & vbTab & count & "、" & currentFile
        Else
            s = s & vbCrLf & count & "、" & currentFile
        End If
    Loop
    Debug.Print s
    
    ActiveSheet.UsedRange.Rows.AutoFit
    ActiveSheet.UsedRange.Columns.AutoFit
    
End Sub


Sub grabTxtFiles()
 Set dic = CreateObject("Scripting.Dictionary")
 
 ' some preparation, for demonstration
 Dim j As Integer
  j = Worksheets.count
  MsgBox "当前工作簿的工作表数为:" & Chr(10) & j
'  Worksheets.Add after:=Worksheets("sheet1")    ' add a new worksheet
  Worksheets.Add after:=Sheets(Sheets.count) ' add a new worksheet in the end
  j = Worksheets.count
  MsgBox "当前工作簿的工作表数为:" & Chr(10) & j
  Sheets(Worksheets.count).Select
  
     ' (1) traverse each subfolder in the given directory
    Dim fso, fDirectory, fs, fsubfolders, currSubFolder
    Dim strDataDirectory As String
    Dim i As Integer
    Dim nFileCount As Integer
        
    strDataDirectory = "D:\sources\demo"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fDirectory = fso.GetFolder(strDataDirectory)
    Set fsubfolders = fDirectory.SubFolders
   
    ActiveSheet.Range("D" & 1) = "子文件夹txt文件列表"
    i = 2
    For Each folder In fsubfolders
        Debug.Print folder.Name
        Set currSubFolder = folder                ' current subfolder
        Set fs = currSubFolder.Files     '文件集合
        For Each f In fs                '遍历文件
            If InStr(LCase(f.Name), "txt") Then '用instr方法比对文件名称是否包含指定字符
                ActiveSheet.Range("D" & i) = f
                dic.Add i, f  ' add to the dictionary container
                i = i + 1
            End If
        Next
    Next
    nFileCount = i
    
     ' traverse each txt file in the the current directory
    Set filesInCurrFolder = fDirectory.Files
    ActiveSheet.Range("E" & 1) = "当前文件夹txt文件列表"
    i = 2
    For Each file In filesInCurrFolder
        If InStr(LCase(file.Name), "txt") Then '用instr方法比对文件名称是否包含指定字符
            ActiveSheet.Range("E" & i) = file
            i = i + 1
            nFileCount = nFileCount + 1
            dic.Add nFileCount, file  ' add to the dictionary container
        End If
    Next
    Range("G2").Resize(dic.count, 1) = Application.WorksheetFunction.Transpose(dic.Keys)
    Range("H2").Resize(dic.count, 1) = Application.WorksheetFunction.Transpose(dic.Items)
    
    For Each Item In dic.Items
        Debug.Print Item
    Next
    
    Set dic = Nothing ' destruct object and free its memory
    ActiveSheet.UsedRange.Rows.AutoFit
    ActiveSheet.UsedRange.Columns.AutoFit
End Sub

Sub dictDemo()

    Set dic = CreateObject("Scripting.Dictionary") '字典
    For i = 1 To 1000
        If Not i Like "*4*" Then '如果不包含“4”
            dic.Add i, i * i '添加键和项目(key,item),其中键不能重复
        End If
    Next
    dic("张三") = "Bruce"  ' 键值对赋值
    MsgBox dic.Exists("张三")
    Range("A2").Resize(dic.count, 1) = Application.WorksheetFunction.Transpose(dic.Keys) '从A2单元开始向下放置一维数组dic.keys
    Range("B2").Resize(dic.count, 1) = Application.WorksheetFunction.Transpose(dic.Items)
    
    arrKeys = dic.Keys  ' 把集合当成一维数组用
    arrItems = dic.Items
    For i = 1 To dic.count - 1
        Debug.Print arrKeys(i)
        Debug.Print arrItems(i)
    Next
    
   
'    MsgBox dic.count
'    MsgBox dic.Exists(2) '判断是否存在某个键
    '清空字典
    dic.RemoveAll
'    MsgBox dic.Exists(2) '判断是否存在某个键
    '释放字典对象,清空内存
    Set dic = Nothing
End Sub

  评论这张
 
阅读(184)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2016