VBA各种查询方法介绍和应用举例

ivccav

9.相似度计算

我们在百度查询框中输入一个关键词，为什么总能找到相关性很高的结果呢？这涉及到相似度计算问题。计算字符串相似度的算法有欧几里得距离、海明距离、杰卡德距离、编辑距离、KMP算法等等，商用的汉语相似度算法往往很复杂，要涉及到字形、读音等各种因素，这里只简单说说编辑距离的算法。
编辑距离的算法是首先由俄国科学家Levenshtein提出的，故又叫Levenshtein距离，指的是两个字符串之间，由一个转换成另一个所需的最少编辑操作次数，许可的编辑操作包括将一个字符替换成另一个字符，插入一个字符，删除一个字符。算法原理在《编程之美》3.3节 计算字符串的相似度，（P230，2008年3月第一版）有介绍，网上的资料更多，例如：    https://www.cnblogs.com/sumuncle/p/5632032.html，参照评论3的代码（源代码貌似有些错误，我没有完全按原义改），把它改为完整的VBA代码如下，可供参考：

Function Levenshtein(str1 As String, str2 As String) As Double
    Dim len1&, len2&, i&, j&, dp
    If str1 = str2 Then Levenshtein = 1: Exit Function
    len1 = Len(str1): len2 = Len(str2)
    ReDim dp(len1 + 1, len2 + 1)
    For i = 0 To len1: dp(i, 0) = i: Next
    For i = 0 To len2: dp(0, i) = i: Next
    For i = 1 To len1
        For j = 1 To len2
            If Mid(str1, i, 1) = Mid(str2, j, 1) Then
                dp(i, j) = dp(i - 1, j - 1)
            Else
                dp(i, j) = dp(i - 1, j - 1) + 1 '替换操作
            End If
'             dp(i - 1, j) + 1  删除操作        dp(i, j - 1) + 1  插入操作
            dp(i, j) = Application.WorksheetFunction.min(dp(i, j), dp(i - 1, j) + 1, dp(i, j - 1) + 1)
        Next
    Next
    Levenshtein = 1 - dp(len1, len2) / Application.WorksheetFunction.Max(len1, len2)
End Function

10.其他方法

    工作表函数MATCH， FIND，SEARCH等也可以在VBA中使用来查询，工作表函数只要使用Application.WorksheetFunction为前缀即可，但这些都是非主流用法，略去不讲了。

ivccav

11.查询过程的效率问题
上面的各种技术只是解决了查询和匹配问题，还有输出问题效率问题需要解决。如果查询数据集庞大，比如有百万行数据，就需要注意查询过程中的效率问题，程序设计不好，会严重影响运行效率，后果就是体验效果不佳。造成运行效率低下的原因除了程序代码的问题外，还有两个原因：多余的显示和多余的查询。

11.1多余的显示

一般创建的查询系统是在窗体中设置一个TEXTBOX查询框，然后运用Change事件根据输入值自动查询并显示符合条件的数据子集。通过分析得知，当我们输入的查询关键词很少时，比如一个字符时，肯定会匹配绝多部分数据，但这些数据都不是最终想要的结果，如果我们把这些数据都显示出来，会造成极大地输出效率问题，因为向列表控件（Listbox、Listview等）添加数据并显示出来，是低效的。同时也是一种浪费，因为这么庞大的结果集没法看，只能导出到文件另行处理。多余的显示可以用分页技术解决，减轻输出到显示的压力，即每次只显示一部分结果，如果确有需要，再逐步显示剩余的数据。

先说使用ADO查询的分页技术。

（1）我们可新建一个窗体，并初始化：
Private Sub UserForm_Initialize()
    Dim sql$, i&, j&, col&, a()
    With Sheet2
        col = .Range("A1").CurrentRegion.Columns.Count '列数
        ReDim a(col - 1)
        For i = 0 To UBound(a)
            a(i) = .Columns(i + 1).ColumnWidth * 10 '创建Listview列宽数据
        Next
    End With
    Set cnn = CreateObject("adodb.connection")
    Set rs0 = CreateObject("adodb.recordset")
    cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data Source=" & ThisWorkbook.FullName
    sql = "select * from [数据库$A1:D] where 1<>1" '只要标题，不要数据
    rs0.Open sql, cnn, 1, 3

    With ListView1
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        For i = 0 To rs0.Fields.Count - 1
            If i > 0 Then
                .ColumnHeaders.Add , , rs0.Fields(i).Name, a(i), lvwColumnCenter
            Else
                .ColumnHeaders.Add , , rs0.Fields(i).Name, a(i)
            End If
        Next i
    End With
    Label2 = "准备就绪"
    模糊查询.SetFocus
End Sub

（2）在文本框“模糊查询”的Change事件中创建查询语句，根据用户输入内容动态查询数据。注意，rst是一个公共Recordset对象，用来存储查询后的结果集，然后调用“下一页”子过程显示第一页：

Private Sub 模糊查询_Change()
    Dim sql$, temp$, i&, j&, s$
    Set rst = CreateObject("adodb.recordset")
    temp = 模糊查询.Text
    sql = "select * from [数据库$A1:D]"
    If temp <> "" Then '模糊查询.Text不为空
        For i = 0 To rs0.Fields.Count - 1 '逐个字段,从0开始循环结果集全部列
            s = s & " or " & rs0.Fields(i).Name & " like '%" & temp & "%'" '查询字符串
        Next i
        sql = sql & " where " & Mid(s, 4)
    End If
    rst.Open sql, cnn, 1, 3
    Call 下一页
End Sub

（3）分页代码包括显示上一页和下一页，算法代码如下：

Private Sub 下一页()
    Dim i&, j&
    If rst.RecordCount = 0 Then Label2.Caption = "共找到 0 条记录": ListView1.ListItems.Clear: Exit Sub
    Label2.Caption = "共找到 " & rst.RecordCount & " 条记录"
    If rst.EOF Then MsgBox "已显示所有数据": Exit Sub
    If rst.BOF Then rst.Move ListView1.ListItems.Count + 1

    With ListView1
        .ListItems.Clear
        Do While Not rst.EOF
            i = i + 1
            If i > 10 Then Exit Do '每次显示10条
            .ListItems.Add , , rst.Fields(0).Value
            For j = 1 To rst.Fields.Count - 1
                .ListItems(i).SubItems(j) = rst.Fields(j).Value
            Next j
            rst.MoveNext
        Loop
    End With

End Sub

Private Sub 上一页()
    Dim i&, j&
    If rst.RecordCount = 0 Then Label2.Caption = "共找到 0 条记录": ListView1.ListItems.Clear: Exit Sub
    Label2.Caption = "共找到 " & rst.RecordCount & " 条记录"
    If rst.BOF Then MsgBox "已显示所有数据": Exit Sub

    rst.Move -(ListView1.ListItems.Count + 10) '每次倒退10条(显示多少条就倒退多少条)
    If rst.BOF Then MsgBox "已显示所有数据": Exit Sub

    With ListView1
        .ListItems.Clear
        Do While Not rst.EOF
            i = i + 1
            If i > 10 Then Exit Do '每次显示10条
            .ListItems.Add , , rst.Fields(0).Value
            For j = 1 To rst.Fields.Count - 1
                .ListItems(i).SubItems(j) = rst.Fields(j).Value
            Next j
            rst.MoveNext
        Loop
    End With

End Sub

使用ADO方法的好处是，Recordset对象会记住数据移动到哪一行，不需要你去控制。但有时候不适合使用ADO技术，因为数据比较乱，或者不规范，这时候就得使用数组的方式。

使用数组的分页技术

（1）同样，创建一个窗体并初始化。这里drr是数据源数组，crr是保存查询结果的数组，都是模块级公共变量，方便不同过程调用。
Private Sub UserForm_Initialize()
    Dim i&, a
    With Sheet2
        drr = .Range("A2").CurrentRegion
        ReDim a(UBound(drr, 2) - 1)
        For i = 0 To UBound(a)
            a(i) = .Columns(i + 1).ColumnWidth * 10
        Next
    End With
    With ListView1
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        For i = 1 To UBound(drr, 2)
            If i > 1 Then
                .ColumnHeaders.Add , , drr(1, i), a(i - 1), lvwColumnCenter
            Else
                .ColumnHeaders.Add , , drr(1, i), a(i - 1)
            End If
        Next i
    End With
    Label2 = "准备就绪"
    模糊查询.SetFocus
End Sub

（2）在文本框“模糊查询”的Change事件中创建查询语句，根据用户输入内容动态查询数据。注意代码中的注释说明。Preserve运算效率比较低，其实可以每次把维数扩展100甚至1000，这样就能减少Preserve的使用次数，同时也不会浪费多少数组空间。当然也可以定义一个跟数据源数组一样大小的数组来保存查询结果，这样就不需要Preserve和转置，效率更高。也可以定义一个跟数据源数组行数一样多的数组，只保存符合条件的数据的行号，这样查询结果的保存会更轻松。待需要输出时根据行号可一步到位地找到数据行。这个代码可自行完成。

Private Sub 模糊查询_Change()
    Dim txt$, i&
    If IsEmpty(drr) Then Exit Sub
    txt = 模糊查询.Text
    If Len(txt) = 0 Then Exit Sub
    cnt = 0 '记录符合查询条件的数据的条数
    pos = 0 '记录每次输出之后crr数组的位置
    ReDim crr(1 To 4, 1 To 1) '每次查询都需要重定义crr。
    For i = 2 To UBound(drr)
        If InStr(drr(i, 1) & "/" & drr(i, 2) & "/" & drr(i, 3) & "/" & drr(i, 4), txt) Then
            u = UBound(crr, 2)
            For j = 1 To 4
                crr(j, u) = drr(i, j)
            Next
            cnt = cnt + 1
            ReDim Preserve crr(1 To 4, 1 To u + 1)
        End If
    Next


'    Preserve效率比较低，其实可以每次把维数扩展100甚至1000，
'    这样就能减少Preserve的使用次数，也不会浪费多少数组空间。

'    ReDim crr(1 To 4, 1 To 100)
'    For i = 2 To UBound(drr)
'        If InStr(drr(i, 1) & "/" & drr(i, 2) & "/" & drr(i, 3) & "/" & drr(i, 4), txt) Then
'            cnt = cnt + 1
'            If cnt Mod 100 = 0 Then ReDim Preserve crr(1 To 4, 1 To UBound(crr, 2) + 100)
'            For j = 1 To 4
'                crr(j, cnt) = drr(i, j)
'            Next
'        End If
'    Next

'    当然也可以定义一个跟数据源数组一样大小的数组来保存查询结果，
'    这样就不需要Preserve和转置，效率更高。
'    也可以定义一个跟数据源数组行数一样多的数组，只保存符合条件的
'    数据的行号，这样查询结果的保存会更轻松。待需要输出时根据行号
'    可一步到位地找到数据行。这个代码可自行完成。

    crr = transpose(crr)
    Call 下一页
End Sub

（3）数组的分页代码如下：
Private Sub 下一页()
    Dim i&, j&, k&
    If cnt = 0 Then Label2.Caption = "共找到 0 条记录": ListView1.ListItems.Clear: Exit Sub
    Label2.Caption = "共找到 " & cnt & " 条记录"
    If pos >= cnt Then MsgBox "已显示所有数据": Exit Sub
    If pos = 0 Then pos = 1 'Listview中没有显示过数据的情形pos为零
    If pos < 0 Then pos = ListView1.ListItems.Count + 1
    With ListView1
        .ListItems.Clear
        For i = pos To cnt
            k = k + 1
            If k > 10 Then Exit For '每次显示10条
            .ListItems.Add , , crr(i, 1)
            For j = 1 To 3
                .ListItems(k).SubItems(j) = crr(i, j+1)
            Next
        Next
        pos = i
    End With
End Sub

Private Sub 上一页()
    Dim i&, j&
    If cnt = 0 Then Label2.Caption = "共找到 0 条记录": ListView1.ListItems.Clear: Exit Sub
    Label2.Caption = "共找到 " & cnt & " 条记录"
    If pos <= 0 Then MsgBox "已显示所有数据": Exit Sub
    pos = pos - (ListView1.ListItems.Count + 10) '每次倒退10条(显示多少条就要倒退多少条)
    If pos <= 0 Then MsgBox "已显示所有数据": Exit Sub
    With ListView1
        .ListItems.Clear
        For i = pos To cnt
            k = k + 1
            If k > 10 Then Exit For '每次显示10条
            .ListItems.Add , , crr(i, 1)
            For j = 1 To 3
                .ListItems(k).SubItems(j) = crr(i, j+1)
            Next
        Next
        pos = i
    End With
End Sub

p4607596

学习了.很好的一个帖子,

缘之绘

建议给出文件，好根据文件实验。更加深刻理解

一执成念

很好的总结

ivccav

11.2多余的查询


查询的过程不一定需要显示所有数据，有时候也不一定需要查询所有数据。很多时候我们查询的结果都是可预知的很小的数据子集，比如查询某个账号的资料数据，比如某订单的商品明细，其结果集都是很小的，因此，在逐步输入查询关键词的过程中，根本无需查询整个数据库，因为没有谁会从几千几万行查询结果中去找自己想要的数据，我们只要查询满足条件的100行（或者更少，根据实际情况而定）的数据就可以退出查询循环，等查询关键词输入到足够多的时候，符合条件的结果集都不会超过限定的行数。当然，为了保险起见，每次只查询少量数据，可能会导致数据遗漏，还得有一个让用户显示剩余符合条件的结果的功能。

这种技术因为不是查询整个数据源，且不查询到最后是不知道有多少数据符合查询条件的，结果集是未知的，我称之为动态加载数据，我在http://club.excelhome.net/thread-1424969-1-1.html的第七节中已经介绍过，这里再复习一遍吧。

该方法的核心代码是：

'lv：istView对象，需要新增Listitem的目标对象
'lngIdx：数据数组的起始查询位置，动态加载数据
'lngCount：需要新增满足查询条件的Listitem行数
'lngRowIndex为记录arrData数组当前位置的全局变量
Public Sub AddListItems(lv As ListView, ByVal lngIdx As Long, lngCount As Long)
    Dim i&, j&, n&, strKey$, lstitem As ListItem
    If IsEmpty(arrData) Then Exit Sub
    If lngIdx < LBound(arrData) Or lngIdx > UBound(arrData) Then Exit Sub
    If lngCount < 1 Then lngCount = UBound(arrData) '小于1则加载全部
    txt = 模糊查询.Text
    With lv
        For i = lngIdx To UBound(arrData)
            strKey = arrData(i, 1) & "/" & arrData(i, 2) & "/" & arrData(i, 3) & "/" & arrData(i, 4)
            If InStr(strKey, txt) Then
                n = n + 1’计数器
                If n > lngCount Then Exit For
                Set lstitem = .ListItems.Add
                lstitem.Text = arrData(i, 1)
                For j = 2 To UBound(arrData, 2)
                    lstitem.SubItems(j - 1) = arrData(i, j)
                Next
            End If
        Next
        If i > UBound(arrData) Then lngRowIndex = i Else lngRowIndex = i + 1
    End With
    If lngRowIndex >= UBound(arrData) Then Label2 = "数据加载完了" Else Label2 = "滚动鼠标可继续加载数据……"
End Sub

调用AddListItems时，只要指定从数据源什么位置开始查询，并指定查询多少匹配行即行停止查询即可。在查询框中可直接调用：

Private Sub 模糊查询_Change()
    ListView1.ListItems.Clear
    AddListItems ListView1, 2, 20
End Sub

要想显示更多数据，可新建一个命令按钮，直接调用AddListItems：

Private Sub CommandButton1_Click() '显示更多
    AddListItems ListView1, lngRowIndex, 20
End Sub

如果想要滚动鼠标中键和拖动Listview垂直滚动条也能动态加载数据，只要监测到这些事件时，调用AddListItems即可，非常方便。要监测Listview的鼠标事件需要少量API，窗体初始化时，需要改一下：

Private Sub UserForm_Initialize()
    Dim i&, a
    With Sheet2
        arrData = .Range("a1").CurrentRegion
        ReDim a(UBound(arrData, 2) - 1)
        For i = 0 To UBound(a)
            a(i) = .Columns(i + 1).ColumnWidth * 10
        Next
    End With
    With ListView1
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        For i = 1 To UBound(arrData, 2)
            If i > 1 Then
                .ColumnHeaders.Add , , arrData(1, i), a(i - 1), lvwColumnCenter
            Else
                .ColumnHeaders.Add , , arrData(1, i), a(i - 1)
            End If
        Next
        AddListItems ListView1, 2, 10 '初始化时加载10条数据，如有的话，可自行设置
        LvmPreWndProc = GetWindowLong(.hwnd, GWL_WNDPROC)
        SetWindowLong .hwnd, GWL_WNDPROC, AddressOf WndProc
    End With
    Label2 = "准备就绪"
    模糊查询.SetFocus
End Sub

注意，退出窗体时，需要还原窗体的窗口函数：

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    SetWindowLong ListView1.hwnd, GWL_WNDPROC, LvmPreWndProc
End Sub

监测程序如下：

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
Public Declare Function GetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, lpMinPos As Long, lpMaxPos As Long) As Long
Public Const SB_VERT = 1
Public Const WM_VSCROLL = &H115
Public Const WM_MOUSEWHEEL = &H20A
Public Const GWL_WNDPROC = (-4)

Public LvmPreWndProc As Long
Public arrData, lngRowIndex As Long

Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lngMinPos As Long, lngMaxPos As Long
    With UserForm3
        Select Case Msg
            Case WM_VSCROLL '拖动Listview垂直滚动条
                GetScrollRange hwnd, SB_VERT, lngMinPos, lngMaxPos
                If GetScrollPos(hwnd, SB_VERT) > lngMaxPos - 200 Then
                    If lngRowIndex <= UBound(arrData) Then
                        .AddListItems .ListView1, lngRowIndex, 1
                    End If
                End If
            Case WM_MOUSEWHEEL '滚动鼠标中键
                If wParam = &HFF880000 Then
                    If lngRowIndex <= UBound(arrData) Then
                        .AddListItems .ListView1, lngRowIndex, 1
                    End If
                End If
        End Select
    End With
    WndProc = CallWindowProc(LvmPreWndProc, hwnd, Msg, wParam, lParam)
End Function

ivccav

12．总结

    本帖介绍的查询技术包括匹配过程和输出过程。匹配过程最常使用Instr、Like、正则表达和字典，但是ADO方式在多人协作环境更常用，因为多人协作的环境基本涉及到数据库。Range对象的Find方法、自动筛选和高级筛选功能也可以方便的使用，如果不追求效率的话。相似度计算在某些场合也是可以使用的。熟悉这些方法对于我们的编程能力的提高应该会有所裨益。

--End--

ivccav

缘之绘 发表于 2018-12-8 11:10
建议给出文件，好根据文件实验。更加深刻理解

有附件的，在2楼，不过还需要审核，请耐心等一下。

ivccav

可以这么说，只要不是对所有数据都进行处理，基本上都涉及到查询问题，要通过查询操作辨识需要处理的数据。其实密码也是需要查找的，你的论坛密码不会明文保存在论坛数据库，而会计算出MD5保存在数据库。那样，就算别人知道你密码的MD5值也没有用，因为MD5是不可逆的运算，无法根据MD5倒退出你的密码明文。看到很多朋友做的登录系统都保存密码明文，其实通过MD5运算再保存会安全得多。

有时候文件也需要查询匹配是否一致。比如秒传技术，本质就是MD5算法，网盘或者其他文件服务器会先计算你传输文件的MD5，然后跟它数据库里面的MD5值比对，如果你的文件的MD5在数据库中存在，你的文件根本不会被传输，这就是秒传。还有，下载软件也会使用MD5搜索资源，因为每个人保存的文件名可能不同，且比较文件名是不可靠的，同名的文件很大，而通过MD5就能找到确定相同的文件。再分享一个计算文件MD5的代码，算法是API函数，供大家参考：

1. Option Base 0
   
2. Public Declare Sub MD5Init Lib "Cryptdll.dll" (ByVal pContex As Long)
   
3. Public Declare Sub MD5Final Lib "Cryptdll.dll" (ByVal pContex As Long)
   
4. Public Declare Sub MD5Update Lib "Cryptdll.dll" (ByVal pContex As Long, ByVal lPtr As Long, ByVal nSize As Long)
   
5. Public Type MD5_CTX
   
6.     i(1) As Long
   
7.     buf(3) As Long
   
8.     inc(63) As Byte
   
9.     digest(15) As Byte
   
10. End Type
    
11. 
    
12. Public cnt As Long
    
13. 
    
14. Public Function ConvBytesToBinaryString(bytesIn() As Byte) As String
    
15.     Dim i As Long
    
16.     Dim nSize As Long
    
17.     Dim strRet As String
    
18.     nSize = UBound(bytesIn)
    
19.     For i = 0 To nSize
    
20.          strRet = strRet & Right$("0" & Hex(bytesIn(i)), 2)
    
21.     Next
    
22.     ConvBytesToBinaryString = strRet
    
23. End Function
    
24. 
    
25. Public Function GetMD5Hash(bytesIn() As Byte) As Byte()
    
26.     Dim ctx As MD5_CTX
    
27.     Dim nSize As Long
    
28.     nSize = UBound(bytesIn) + 1
    
29.     MD5Init VarPtr(ctx)
    
30.     MD5Update ByVal VarPtr(ctx), ByVal VarPtr(bytesIn(0)), nSize
    
31.     MD5Final VarPtr(ctx)
    
32.     GetMD5Hash = ctx.digest
    
33. End Function
    
34. 
    
35. Public Function GetMD5Hash_Bytes(bytesIn() As Byte) As String
    
36.     GetMD5Hash_Bytes = ConvBytesToBinaryString(GetMD5Hash(bytesIn))
    
37. End Function
    
38. 
    
39. Public Function GetMD5Hash_String(ByVal strIn As String) As String
    
40.     GetMD5Hash_String = GetMD5Hash_Bytes(StrConv(strIn, vbFromUnicode))
    
41. End Function
    
42. 
    
43. Public Function GetMD5Hash_File(ByVal strFile As String) As String
    
44.     Dim lFile As Long
    
45.     Dim bytes() As Byte
    
46.     Dim lSize As Long
    
47.     lSize = FileLen(strFile)
    
48.     If (lSize) Then
    
49.         lFile = FreeFile
    
50.         ReDim bytes(lSize - 1)
    
51.         Open strFile For Binary As lFile
    
52.         Get lFile, , bytes
    
53.         Close lFile
    
54.         GetMD5Hash_File = GetMD5Hash_Bytes(bytes)
    
55.     End If
    
56. End Function
    
57. 
    
58. Sub Getfd(ByVal pth As String, arr)
    
59.     Dim fso As Object, f, fd, ff
    
60.     Set fso = CreateObject("scripting.filesystemobject")
    
61.     Set ff = fso.getfolder(pth)
    
62.     For Each f In ff.Files
    
63.         cnt = cnt + 1
    
64.         If cnt Mod 1000 = 0 Then ReDim Preserve arr(1 To 6, 1 To UBound(arr, 2) + 1000)
    
65.         arr(1, cnt) = f
    
66.         arr(2, cnt) = f.DateCreated
    
67.         arr(3, cnt) = f.DateLastModified
    
68.         arr(4, cnt) = f.Type
    
69.         arr(5, cnt) = Format(f.Size / 1048576, "0.00MB")
    
70.         arr(6, cnt) = GetMD5Hash_File(f)
    
71.     Next
    
72.     For Each fd In ff.subfolders: Getfd fd, arr: Next
    
73. End Sub
    
74. 
    
75. Function transpose(drr)
    
76.     Dim brr(), L1&, U1&, L2&, U2&
    
77.     L1 = LBound(drr): U1 = UBound(drr)
    
78.     L2 = LBound(drr, 2): U2 = UBound(drr, 2)
    
79.     ReDim brr(L2 To U2, L1 To U1)
    
80.     For i = L1 To U1
    
81.         For j = L2 To U2
    
82.             If IsNull(drr(i, j)) Then drr(i, j) = ""
    
83.             brr(j, i) = drr(i, j)
    
84.         Next
    
85.     Next
    
86.     transpose = brr
    
87. End Function
    
88. 
    
89. Sub AllFiles()
    
90.     Dim pth$, arr
    
91.     Application.ScreenUpdating = False
    
92.     With Application.FileDialog(msoFileDialogFolderPicker)
    
93.         If .Show = -1 Then
    
94.             pth = .SelectedItems(1)
    
95.         Else
    
96.             MsgBox "您没有选择任何文件夹！", vbCritical: Exit Sub
    
97.         End If
    
98.     End With
    
99.     cnt = 0
    
100.     ReDim arr(1 To 6, 1 To 1000)
     
101.     Getfd pth, arr
     
102.     arr = transpose(arr)
     
103.     With ActiveSheet
     
104.         .UsedRange.Clear
     
105.         .Cells(1, 1) = "文件名称"
     
106.         .Cells(1, 2) = "创建日期"
     
107.         .Cells(1, 3) = "修改日期"
     
108.         .Cells(1, 4) = "文件类型"
     
109.         .Cells(1, 5) = "文件大小"
     
110.         .Cells(1, 6) = "MD5 数值"
     
111.         .Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
     
112.         r = .Range("a" & Rows.Count).End(3).Row
     
113.         .Range("a1:f" & r).Borders.LineStyle = xlContinuous
     
114.         .Range("a1:f" & r).Borders.Weight = xlThin
     
115.     End With
     
116.     Application.ScreenUpdating = True
     
117.     MsgBox "文件已全部获取！点『确定』键结束"
     
118. End Sub

复制代码

计算文件md5.zip (30.63 KB, 下载次数: 301)

2018-12-8 21:10 上传

点击文件名下载附件

民扬

好货一定要收藏。