汇总某文件夹下的多个workbook统计数据

wang_jg

ykcbf1100 发表于 2024-3-11 11:56
代码如下：

可能叙述的不准确，重新上传了原始表格，请针对重新上传的原始表格进行操作。
原始表格里面没有“汇总”这些的，标蓝色的，黄色的单元格是手工函数计算用的，原始表格里面没有。

ykcbf1100

wang_jg 发表于 2024-3-11 12:50
可能叙述的不准确，重新上传了原始表格，请针对重新上传的原始表格进行操作。
原始表格里面没有“汇总” ...

看吧，从一开始你的求助就不认真。来回折腾大家都浪费时间。

wang_jg

叙述不准确，抱歉

ykcbf1100

wang_jg 发表于 2024-3-11 13:32
叙述不准确，抱歉

让别人陪你玩吧。
我不想再浪费时间。

fzxba

测试参考.zip (188.39 KB, 下载次数: 10)

2024-3-11 14:59 上传

点击文件名下载附件

fzxba

Sub test0() '我陪着玩一下
  
  Dim strPath As String
  
  'With Application.FileDialog(msoFileDialogFolderPicker)
  '.InitialFileName = ThisWorkbook.Path
  'If .Show Then strPath = .SelectedItems(1) Else Exit Sub
  'End With
  'If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  '
  strPath = ThisWorkbook.Path & "\origin1\"
  
  Dim ar, vFiles(1, 1 To 234) As String
  Dim Conn As Object, wks As Worksheet, Fso As Object ', Dict As Object
  Dim strConn As String, SQL As String, s As String
  Dim i As Long, r As Long, k As Long, j As Long, p As Long, c As Long, iCount As Long
  
  'Dim Fso As New FileSystemObject, Dict As New Dictionary
  
  k = 1
  Set wks = Worksheets("按月分任务汇总")
  wks.Range("C2:E14").ClearContents
  
  DoApp False
  
  For i = Worksheets.Count To 3 Step -1
    Worksheets(i).Delete
  Next
  
  Set Conn = CreateObject("ADODB.Connection")
  'Set Dict = CreateObject("Scripting.Dictionary")
  
  s = "Excel 12.0;HDR=NO;IMEX=1;Database="
  If Application.Version < 12 Then
    s = Replace(s, "12.0", "8.0")
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
  Else
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
  End If
  'Conn.Open strConn & ThisWorkbook.FullName
  
  Set Fso = CreateObject("Scripting.FileSystemObject")
  GetFiles strPath, Fso, vFiles, iCount, "~$", ".xls"
  Set Fso = Nothing
  
  For i = 1 To iCount
    If vFiles(1, i) <> ThisWorkbook.FullName Then
      k = k + 1
      wks.Cells(k, 3) = vFiles(0, i)
      If Conn.State <> 1 Then Conn.Open strConn & vFiles(1, i)
      SQL = "SELECT * FROM [" & s & vFiles(1, i) & "].[$A:IU] WHERE F1 LIKE '202%'"
      With Worksheets.Add(After:=Worksheets(Worksheets.Count))
        .Name = vFiles(0, i)
        .Range("A1").CopyFromRecordset Conn.Execute(SQL)
        j = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
        SQL = "SELECT * FROM [" & s & vFiles(1, i) & "].[$A" & j + 1 & ":IU" & j + 2 & "]"
        .Range("A" & j + 1).CopyFromRecordset Conn.Execute(SQL)
        p = .Cells.Find("有效帧数", , xlValues, , xlByColumns, xlPrevious).Column
        c = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
        ar = .Cells(1, p).Resize(j + 2, c - p + 2)
        ar(j + 1, UBound(ar, 2)) = "总计"
        For r = 1 To j
          ar(j + 2, 1) = ar(j + 2, 1) + Val(ar(r, 1))
          For c = 2 To UBound(ar, 2) - 1
            ar(r, UBound(ar, 2)) = ar(r, UBound(ar, 2)) + Val(ar(r, c))
          Next
          ar(j + 2, c) = ar(j + 2, c) + ar(r, c)
        Next
        wks.Cells(k, 4) = ar(j + 2, 1)
        wks.Cells(k, 5) = ar(j + 2, c)
        .Cells(1, p).Resize(j + 2, UBound(ar, 2)) = ar
      End With
    End If
  Next
  
  wks.Activate
  
  If Conn.State = 1 Then Conn.Close
  Set Conn = Nothing
  'Set Dict = Nothing
  Set wks = Nothing
  
  DoApp True
  Beep
End Sub

Function GetFiles(strPath As String, Fso As Object, vFiles() As String, iCount As Long, strExclude As String, Optional strFilter As String = ".xls")
  Dim oFolder As Object, oFile As Object
  For Each oFile In Fso.GetFolder(strPath).Files
    If InStr(LCase(oFile.Name), strFilter) Then
      If Not oFile.Name Like strExclude & "*" Then
        iCount = iCount + 1
        vFiles(0, iCount) = Fso.GetBaseName(oFile)
        vFiles(1, iCount) = oFile.Path
      End If
    End If
  Next
End Function

Function DoApp(Optional b As Boolean = True)
  With Application
    .ScreenUpdating = b
    .DisplayAlerts = b
    .Calculation = -b * 30 - 4135
  End With
End Function

wang_jg

fzxba 发表于 2024-3-11 15:05
Sub test0() '我陪着玩一下
  
  Dim strPath As String

效果蛮好的，&#128077;怎么还用到SQL了？

cnmlgb9998

PQ  解千愁！！！！！！一个简单的合并文件。

wang_jg

cnmlgb9998 发表于 2024-3-11 21:27
PQ  解千愁！！！！！！一个简单的合并文件。

没看懂，用的什么软件？

cnmlgb9998

wang_jg 发表于 2024-3-12 09:58
没看懂，用的什么软件？

搜 power query