|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
注:下段代码求解文件扩展名,以便把xls文件和其他文件分离出来.
Public Function SplitPath(FullPath, ResultFlag As Integer) As String '
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "\")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
SplitPath = Left(FullPath, SplitPos - 1)
Case 1
If DotPos = 0 Then DotPos = Len(FullPath) + 1
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
If DotPos = 0 Then DotPos = Len(FullPath)
SplitPath = Mid(FullPath, DotPos + 1)
Case Else
Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
-------------------------------------------------------------------------------------------------------
注:下面代码创建交错数组记录参与求和的工作表内容,并对数组结果求和.
Sub total_1()
Dim fn, fld, strPath$
Dim obj As Object
Dim Sh As Worksheet
Dim DB As ADODB.Connection
Dim FileName As String
Dim TableRst As ADODB.Recordset '定义表
Dim ColumnRst As New ADODB.Recordset '定义字段
Dim rs As Recordset '定义记录
Set DB = New ADODB.Connection
Set rs = New Recordset
strPath = ThisWorkbook.Path
Set obj = CreateObject("Scripting.FileSystemObject")
Set fld = obj.GetFolder(strPath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each fn In fld.Files
On Error Resume Next
If SplitPath(fn.Name, 2) = "xls" And fn.Name <> ThisWorkbook.Name Then '筛选后缀为.xls的文件
i = i + 1 '统计工作簿数量
If i > 1 Then '假设参与汇总求和的工作簿的工作表数量都一样,故只需要测试一个工作簿的工作表数.
GoTo 1
Else
FileName = ThisWorkbook.Path & "\" & fn.Name
DB.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False; Data Source=" & FileName & ";Extended Properties='Excel 8.0;IMEX=1;HDR=no'"
Set TableRst = DB.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))
TableRst.MoveFirst
While Not TableRst.EOF '遍历每个表
'Table = TableRst!TABLE_NAME 'Table 变量 也可 TableRst!TABLE_NAME.Value 也可 TableRst("TABLE_NAME").Value
j = j + 1 '统计单个工作簿工作表数量
TableRst.MoveNext
Wend
1
End If
End If
Next
DB.Close
'Set TableRst = Nothing: Set DB = Nothing
ReDim s(0 To i - 1, 0 To j - 1) '定义二维数组,表示所处工作簿及工作表位置
For Each fn In fld.Files
On Error Resume Next
If SplitPath(fn.Name, 2) = "xls" And fn.Name <> ThisWorkbook.Name Then '筛选后缀为.xls的文件
u = u + 1 '计量工作簿所在文件夹的顺序号
FileName = ThisWorkbook.Path & "\" & fn.Name
DB.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False; Data Source=" & FileName & ";Extended Properties='Excel 8.0;IMEX=1;HDR=no'"
Set TableRst = DB.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))
v=0 '每访问一工作簿初始化工作表顺序初始值为0
TableRst.MoveFirst
While Not TableRst.EOF '遍历每个表
Table = TableRst!TABLE_NAME 'Table 变量 也可 TableRst!TABLE_NAME.Value 也可 TableRst("TABLE_NAME").Value
v = v + 1 '计量工作表所在工作簿顺序号
If rs.State = adStateOpen Then rs.Close
rs.Open "Select * from [" & Table & "]", DB, adOpenStatic, adLockOptimistic 'adOpenDynamic
m = rs.Fields.Count '取得工作表的字段数
If Not rs.EOF Then
rs.MoveLast
n = rs.RecordCount '取得工作表的记录行数
Else
'Response.Write "没有记录"
End If
ReDim arr(0 To m - 1, 0 To n - 1) '每访问一工作表,定义数组arr记录工作表单元格值
For fieldcount = 0 To m - 1
l = 0
rs.MoveFirst
Do While Not rs.EOF
l = l + 1
'MsgBox l
If IsNull(rs.Fields(fieldcount)) Then
arr(fieldcount, l - 1) = 0
Else
arr(fieldcount, l - 1) = rs.Fields(fieldcount)
End If
rs.MoveNext
Loop
Next
s(u - 1, v - 1) = arr '交错数组赋值
TableRst.MoveNext
Wend
End If
db.close
Next fn
DB.Close
Set rs = Nothing: Set DB = Nothing
For Each Sh In ThisWorkbook.Worksheets
Sh.Cells.Clear
Next
For v = 0 To j - 1
For u = 0 To i - 1
For x = 0 To UBound(s(u, v), 1)
For y = 0 To UBound(s(u, v), 2)
If IsNumeric(s(u, v)(x, y)) Then
ThisWorkbook.Worksheets(v + 1).Cells(y + 1, x + 1) = ThisWorkbook.Worksheets(v + 1).Cells(y + 1, x + 1) + s(u, v)(x, y)
Else
ThisWorkbook.Worksheets(v + 1).Cells(y + 1, x + 1) = s(0, v)(x, y) '如果不为数值,则本工作簿工作表中单元格为第一张工作簿对应单元格数值,往往为文本性质单元格.
End If
Next
Next
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
|
|
楼主: 我会哭的像英雄
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-6-24 17:14
楼主
哈啥哟
