请老师帮忙修改代码

tulip_ll

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


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


原代码limonet老师编写的，已解决上述问题。
因所有的文件名中间空格改为中划线，程序执行不了。请老师帮助修改！
期待各位大神老师的回复！不甚感激！

tulip_ll

老师编写的原代码如下：
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

hlxue

是不是要这样的？请好评+2分，谢谢！

tulip_ll

hlxue 发表于 2024-4-17 09:34
是不是要这样的？请好评+2分，谢谢！

完美解决，老师，我怎么看不出来哪里改动了呢

hlxue

tulip_ll 发表于 2024-4-17 09:56
完美解决，老师，我怎么看不出来哪里改动了呢

     以下代码将FileName中的“-”替换成“ ”就行了。
  If InStr(FileName, "-") > 0 Then
        Filename1 = Replace(FileName, "-", " ")
        Else
        Filename1 = FileName
        End If
        Arr(i, 1) = Split(Filename1)(0)
        Arr(i, 2) = Split(Split(Filename1)(1), ".xlsx")(0)

tulip_ll

嗯看到区别了，谢谢大神老师们
如果文件夹和EXCEL不一致，能否实现，只写入其中一个。
因为现在测试过程发现EXCEL表有、文件夹没有的人员，小程序不执行。文件夹有、EXCEL表没有的人员，程序可执行人员直接不写入对比表