EXCEL表中数字求和和文件夹图片个数对比

tulip_ll

请老师帮助实现：
EXCEL表中数字求和和文件夹图片个数对比（如示例）

1.EXCEL表中的,档案号、姓名和对应的所有sheet表的F列页数求和显示在“对比表B列C列D列”
2.按姓名统计文件夹中的图片个数显示在“对比表E列”
3.文件夹会有几百人的EXCEL表和图片文件夹
4.如果目录更改，代码写入可以覆盖掉之前的。

期待各位大神老师的回复！不甚感激！

limonet

关键字：adox.catalog、POWERSHELL等

limonet

Sub Limonet()
    Dim Cat As Object, Cn As Object, ObjTable As Object
    Dim Path$, FileName$, StrCn$, StrSQL$, Arr As Variant, Brr As Variant, StrCommand$
    Set WshShell = CreateObject("WScript.Shell")
    ReDim Arr(1 To 3, 1 To 5)
    Set Cat = CreateObject("ADOX.Catalog")
    Set Cn = CreateObject("ADODB.Connection")
    Path = ThisWorkbook.Path & "\"
    FileName = Dir(Path & "*.xlsx")
    Do While FileName <> ""
        i = i + 1
        StrCn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Path & FileName
        Cn.Open StrCn
        Cat.ActiveConnection = StrCn
        For Each ObjTable In Cat.Tables
            If Not ObjTable.Name Like "*FilterDatabase" And ObjTable.Type = "TABLE" And ObjTable.Name <> "报送单$" Then
                StrSQL = StrSQL & " Union All Select * From [Excel 12.0;DataBase=" & Path & FileName & "].[" & Replace(ObjTable.Name, "'", "") & "F3:F] Where 页数>0"
            End If
        Next ObjTable
        StrSQL = "Select Sum(页数) From (" & Mid(StrSQL, 12) & ")"
        Brr = Cn.Execute(StrSQL).Getrows
        Arr(i, 1) = Split(FileName)(0)
        Arr(i, 2) = Split(Split(FileName)(1), ".xlsx")(0)
        Arr(i, 3) = Brr(0, 0)
        StrCommand = "Powershell [System.IO.Directory]::GetFiles('" & Path & Split(FileName, ".xlsx")(0) & "').Count"
        Set WshShellExec = WshShell.Exec(StrCommand)
        Arr(i, 4) = Split(WshShellExec.StdOut.ReadAll, Chr(13))(0)
        Arr(i, 5) = Arr(i, 3) - Arr(i, 4)
        StrSQL = ""
        Cn.Close
        FileName = Dir
    Loop
    Range("B2").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub

tulip_ll

limonet 发表于 2024-4-14 21:23
Sub Limonet()
    Dim Cat As Object, Cn As Object, ObjTable As Object
    Dim Path$, FileName$, St ...

感谢老师，马上去学习

tulip_ll

limonet 发表于 2024-4-14 21:23
Sub Limonet()
    Dim Cat As Object, Cn As Object, ObjTable As Object
    Dim Path$, FileName$, St ...

为什么还会闪烁几下再出结果

tulip_ll

tulip_ll 发表于 2024-4-14 21:35
感谢老师，马上去学习

老师，文件名的格式稍加变化，程序不会改，麻烦老师看看文件夹中空格变成中划线这个代码怎么改动一下
Sub xmbd()
    Dim Cat As Object, Cn As Object, ObjTable As Object
    Dim Path$, FileName$, StrCn$, StrSQL$, Arr As Variant, Brr As Variant, StrCommand$
    Set WshShell = CreateObject("WScript.Shell")
    ReDim Arr(1 To 1000, 1 To 5)
    Set Cat = CreateObject("ADOX.Catalog")
    Set Cn = CreateObject("ADODB.Connection")
    Path = ThisWorkbook.Path & "\"
    FileName = Dir(Path & "*.xlsx")
    Do While FileName <> ""
        i = i + 1
        StrCn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Path & FileName
        Cn.Open StrCn
        Cat.ActiveConnection = StrCn
        For Each ObjTable In Cat.Tables
            If Not ObjTable.Name Like "*FilterDatabase" And ObjTable.Type = "TABLE" And ObjTable.Name <> "报送单$" Then
                StrSQL = StrSQL & " Union All Select * From [Excel 12.0;DataBase=" & Path & FileName & "].[" & Replace(ObjTable.Name, "'", "") & "F3:F] Where 页数>0"
            End If
        Next ObjTable
        StrSQL = "Select Sum(页数) From (" & Mid(StrSQL, 12) & ")"
        Brr = Cn.Execute(StrSQL).Getrows
        Arr(i, 1) = Split(FileName)(0)
        Arr(i, 2) = Split(Split(FileName)(1), ".xlsx")(0)
        Arr(i, 3) = Brr(0, 0)
        StrCommand = "Powershell [System.IO.Directory]::GetFiles('" & Path & Split(FileName, ".xlsx")(0) & "').Count"
        Set WshShellExec = WshShell.Exec(StrCommand)
        Arr(i, 4) = Split(WshShellExec.StdOut.ReadAll, Chr(13))(0)
        Arr(i, 5) = Arr(i, 3) - Arr(i, 4)
        StrSQL = ""
        Cn.Close
        FileName = Dir
    Loop
    Range("B2").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    Range("A2:A65536").ClearContents
            For j = 1 To Cells(Rows.Count, 2).End(xlUp).Row - 1
            Cells(j + 1, 1) = j 'B列
             Next
End Sub