请老师帮忙合并这两个提取数据的VBA，每天做重复的工作太烦人了

fundyc

我收集了本论坛的两位老师数据汇总的VBA，本人小白一个请老师们帮将这两个文件的VBA结合成一个，主要是合并我每天工作日报的需求：
　　　第１个（１选择文件夹数据合并）优点可以选择文件夹，不用将VBA文件复制到要汇总的文件内。直接可以选择文件夹提取数据。
　　　第２个（２文件夹内数据汇总）优点是可以选择提取数据的项目（背景黄色处是填写要汇总的数据列数标题），非常方便提取指定的数据

我已将需求和符件上传，感谢。

ykcbf1100

你这是不同用途的二个代码合并不合适吧，而且还是不同老师写的。

fundyc

ykcbf1100 发表于 2024-10-5 19:50
你这是不同用途的二个代码合并不合适吧，而且还是不同老师写的。

哦！还有最主要的是第二个文件数据汇总，EXCEL宏运行正常，WPS运行报错。

fundyc

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


WPS运行报错

fundyc

leeson7502 发表于 2024-10-6 09:08
wps要装一个32位的Access Database Engine

感谢，不知那个大侠帮忙合并一下这两个VBA

ykcbf1100

还是新写一个吧，fso+字典+数组

附件供参考。。。

ykcbf1100

新写一个吧。

fundyc

ykcbf1100 发表于 2024-10-6 10:31
还是新写一个吧，fso+字典+数组

附件供参考。。。

非常感谢

fundyc

刚刚测试了，非常棒，感谢有你