|
- Option Explicit
- Sub 清除表名空格() '所有工作簿中的2017工作表名中有空格,先运行此段去除空格。
- Application.ScreenUpdating = False
- Dim fil, sh As Worksheet
- For Each sh In ThisWorkbook.Worksheets
- sh.Name = Replace(sh.Name, " ", "")
- Next
- For Each fil In CreateObject("scripting.filesystemobject").GetFolder(ThisWorkbook.Path).Files
- If InStr(fil.Name, ".xlsx") And InStr(fil.Name, "~$") = 0 Then
- With Workbooks.Open(fil)
- For Each sh In .Worksheets
- sh.Name = Replace(sh.Name, " ", "")
- Next
- .Close 1
- End With
- End If
- Next
- Application.ScreenUpdating = True
- MsgBox "ok", 64
- End Sub
- Sub 获取汇总数据()
- Application.ScreenUpdating = False
- Dim a, cnn As Object, fil, sql$, k&, tp, i%, st$, r%, c%
- Set cnn = CreateObject("adodb.connection")
- a = Split("2017 2018")
- For i = 0 To UBound(a)
- k = 0
- For Each fil In CreateObject("scripting.filesystemobject").GetFolder(ThisWorkbook.Path).Files
- If InStr(fil.Name, ".xlsx") And InStr(fil.Name, "~$") = 0 Then
- k = k + 1
- If k = 1 Then
- cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=no';data source=" & fil
- Else
- st = "[Excel 12.0;hdr=no;Database=" & fil & ";]."
- End If
- sql = "SELECT * FROM " & st & "[" & a(i) & "$f8:n25]"
- tp = cnn.Execute(sql).GetRows
- If k = 1 Then
- ReDim ar(0 To UBound(tp, 2), 0 To UBound(tp))
- End If
- For r = 0 To UBound(tp, 2)
- For c = 0 To UBound(tp)
- If tp(c, r) <> "" Then ar(r, c) = ar(r, c) + tp(c, r)
- Next
- Next
- End If
- Next
- If cnn.State = 1 Then cnn.Close
- ThisWorkbook.Sheets(a(i) & "年").[f8].Resize(r, c) = ar
- Next
- Set cnn = Nothing
- Application.ScreenUpdating = True
- MsgBox "ok", 64
- End Sub
复制代码 |
|