|
WPS运行报错,excel很正常。
'*********************************
'******* ******
'******* ******
'*********************************
Sub Opiona()
'禁止系统刷屏?触发其他事件等
'On Error Resume Next '// 发生错误,自动执行下一句,就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
Dim T
T = Timer '//开始时间
Dim SQLARR
Dim I, X As Integer
Dim Str_coon, StrSQL As String
Dim SH1, SH0, SHW As Worksheet
Set SH1 = Sheets("汇总")
SH1.Range("A4:HZ1048576").ClearContents
Rem 组合查询标题
StrBT = ""
For ICOL = 3 To SH1.Range("HZ3").End(xlToLeft).Column
StrBT = StrBT & ",[" & SH1.Cells(3, ICOL).Value & "]"
Next
Rem 获取文件清单
FileArr = FileAllArr(ThisWorkbook.Path, "*.csv", ThisWorkbook.Name, True, False)
If FileArr(0) <> "" Then '//如果文件清单 不是空白的
ICOUNT = UBound(FileArr) + 1
Rem 遍历每个分表文件
For I = 0 To ICOUNT - 1
Str_coon = "HDR=yes';Data Source =" & FileArr(I) '//OFFICE2003,2007 通用
Set WB = Workbooks.Open(FileArr(I)) '//打开工作簿
Rem 遍历工作表
For Each SH In WB.Worksheets
Rem 查询数据
StrSQL = "SELECT '" & GetPathFromFileName(FileArr(I)) & "' AS 工作簿名"
StrSQL = StrSQL & ",'" & SH.Name & "' AS 工作表名"
StrSQL = StrSQL & StrBT
StrSQL = StrSQL & " FROM [" & SH.Name & "$A" & SH1.Range("B1").Value & ":HZ]"
SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
Rem 粘贴到汇总表中
LASTROW = SH1.Range("A1048576").End(3).Row + 1
SH1.Range("A" & LASTROW).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
Next
WB.Close False '//关闭打开的工作簿
Set WB = Nothing
Next
End If
Application.EnableEvents = True '// '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
MsgBox "一共用时:" & Format(Timer - T, "#0.0000") & " 秒", , "已完成 加油" '//提示所用时间
End Sub
'*'****************************************************************************************************
'函数: GetPathFromFileName 根据全路径获得文件名
'参数1: strFullPath 完整路径
'参数2: kzm true 返回字符串含扩展名,默认是:False
'参数3: strSplitor 各级文件夹分隔符
'作用: 从完整路径获取返回: 文件名(true带扩展名)
'使用方法: msgbox GetPathFromFileName("C:\windows\text.txt",true)
'作者: XXX
'*'****************************************************************************************************
Public Function GetPathFromFileName(ByVal strFullPath As String, Optional ByVal kzm As Boolean = False, Optional ByVal strSplitor As String = "\") As String
Dim FileName1 As String
Dim FNAME As String
FileName1 = Left$(strFullPath, InStrRev(strFullPath, strSplitor, , vbTextCompare))
FileName1 = Replace(strFullPath, FileName1, "")
If kzm = False Then
GetPathFromFileName = Left(FileName1, InStrRev(FileName1, ".") - 1)
Else
GetPathFromFileName = FileName1
End If
End Function
'*******************************************************************************************************
'功能: 查找指定文件夹含子文件夹内所有文件名或文件夹名(含路径)
'函数名: FileAllArr
'参数1: Filename 需查找的文件夹名,不包含文件名
'参数2: FileFilter 需要过滤的文件名,可省略,默认为:[*.*]
'参数3: Liwai 剔除例外的文件名,可省略,默认为:空,一般为:ThisWorkbook.Name
'参数4: SubFiles 是否需要查找子文件夹内文件,可省略,默认为:true
'参数5: Files 是否只要文件夹名,可省略,默认为:FALSE
'返回值: 一个字符型的数组
'使用方法:FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false,false)
'作者: XXX
'*******************************************************************************************************
Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal SubFiles As Boolean = True, Optional ByVal Files As Boolean = False) As String()
Dim DIC, DID, Ke, MyName, MyFileName
Dim I As Long
Set DIC = CreateObject("Scripting.Dictionary") '创建一个字典对象
Set DID = CreateObject("Scripting.Dictionary")
Filename = Replace(Replace(Filename & "\", "\\", "\"), "\\", "\")
DIC.Add (Filename), ""
I = 0
Do While I < DIC.Count
Ke = DIC.keys '开始遍历字典
If SubFiles = True Then '//如果需要查找子文件夹
MyName = Dir(Ke(I), vbDirectory) '查找目录
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
DIC.Add (Ke(I) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
End If
End If
MyName = Dir '继续遍历寻找
Loop
End If
I = I + 1
Loop
Dim arrx() As String
I = 0
ReDim arrx(I)
arrx(I) = ""
If Files = True Then '//是否只输出文件夹名
For Each Ke In DIC.keys '以查找总表所在文件夹下所有excel文件为例
ReDim Preserve arrx(I)
If Ke <> Filename Then '//自身文件夹除外
arrx(I) = Ke
I = I + 1
End If
Next
FileAllArr = arrx
Else
For Each Ke In DIC.keys '以查找总表所在文件夹下所有excel文件为例
MyFileName = Dir(Ke & FileFilter) '过滤器:EXCEL2003为:*.xls,excel2007为:*.xlsx
Do While MyFileName <> ""
If MyFileName <> Liwai Then '排除例外文件
ReDim Preserve arrx(I)
arrx(I) = Ke & MyFileName
I = I + 1
End If
MyFileName = Dir
Loop
Next
FileAllArr = arrx
End If
End Function
'*****************************************************************************************
'函数名: GET_SQL_To_Arr
'函数功能: 获得指定SQL的查询结果,自定义连接字符串,可以连接各种数据库
'返回值: 返回一个二维数组
'参数1: StrSQL 字符类型 SQL查询语句
'参数2: Str_coon 字符类型 数据库连接语句
'Str_coon = "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & ThisWorkbook.FullName '//OFFICE2003
'Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source =" & ThisWorkbook.FullName '//OFFICE2007
'Str_coon = "HDR=yes';Data Source =" & FileArr(i) '//OFFICE2003,2007 通用
'参数3: Biaoti 可参数选 是否输出标题,默认带有标题
'使用方法:
' SQLARR= GET_SQL_To_Arr(StrSQL,Str_coon,true)
' SQLARR(0,1) '//数组第一行为标题行,从i=1 开始是数据
' Sh2.Range("A2").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
'整理:XXX
'*****************************************************************************************
Public Function GET_SQL_To_Arr(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
'On Error Resume Next ' 改变错误处理的方式。
Dim CN, RS
Dim arr()
Dim I As Long
Err.Clear
Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
Set RS = CreateObject("adodb.recordset")
Rem Str_coon = "HDR=yes';Data Source=" & ThisWorkbook.FullName
If InStr(Str_coon, "Provider=") = 0 Then
If Val(Application.Version * 1) < 12 Then
Str_coon = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;" & Str_coon
Else
Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;" & Str_coon
End If
End If
CN.CursorLocation = 3
CN.Open Str_coon
RS.Open StrSQL, CN, 1, 3
Rem 如果不要标题,可以:arr = RS.GetRows,代码比较省,但是速度一般
Rem SET RS=CN.Execute(StrSQL)
If RS.RecordCount > 0 Then '//如果找到数据
If Biaoti = True Then
ReDim arr(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
For A = 0 To RS.Fields.Count - 1 '//导入标题
arr(0, A) = RS.Fields(A).Name
Next
For I = 0 To RS.RecordCount - 1 '//导入数据
For A = 0 To RS.Fields.Count - 1
arr(I + 1, A) = RS.Fields(A).Value
Next A
RS.MoveNext
Next
Else
ReDim arr(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
For I = 0 To RS.RecordCount - 1 '//导入数据
For A = 0 To RS.Fields.Count - 1
arr(I, A) = RS.Fields(A).Value
Next A
RS.MoveNext
Next
End If
Else '//如果没有找到数据
If Biaoti = True Then
ReDim arr(0 To 0, 0 To RS.Fields.Count - 1)
For A = 0 To RS.Fields.Count - 1 '//导入标题
arr(0, A) = RS.Fields(A).Name
Next
Else
ReDim arr(0, 0)
arr(0, 0) = ""
End If
End If
If Err.Number <> 0 Then
MsgBox "Error!" & Err.Description
ReDim arr(0, 0)
arr(0, 0) = "Error"
GET_SQL_To_Arr = arr(0, 0)
End If
GET_SQL_To_Arr = arr
RS.Close
CN.Close '//关闭ADO连接
Set RS = Nothing
Set CN = Nothing '//释放内存
End Function
|
|