社区首页 >专栏 >VBA与数据库——合并表格

VBA与数据库——合并表格

xyj

发布于 2021-09-10 06:23:15

5K20

代码可运行

文章被收录于专栏：VBA 学习VBA 学习

运行总次数：0

代码可运行

在Excel里，如果需要把多个工作表或者工作簿的数据合并到一起，用VBA来做一个程序还是比较容易的，在多个工作簿合并到一个工作簿和多个工作表合并到一个工作表里有过介绍，代码不算很复杂。

如果能保证列的一致性，使用ADO合并也是可以的。

合并主要是要用到union all关键字，如果是合并一个工作簿的工作表，sql语句是比较好写的。如果是是多个工作簿数据源的时候，sql语句的用法:

[Excel 12.0;Database=" & Workbook.FullName & ";].[" & Sheet.Name & "$]

代码的核心就是构建出sql语句，首先遍历一个文件夹，获取到需要处理的Excel文件名称，然后按上面的语法构建sql语句，最后调用ado执行就可以了：

Sub UnionAll()
    Dim strsql As String
    
    strsql = UnionAllExcelSQL(ThisWorkbook.path & "\unionall", "Sheet1")
    
    If VBA.Len(strsql) = 0 Then Exit Sub
    
    Dim AdoConn As Object
    Set AdoConn = VBA.CreateObject("ADODB.Connection")
    
    '打开数据库
    AdoConn.Open "Provider =Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.fullname & ";Extended Properties=""Excel 12.0;HDR=YES"";"
    
    Dim rst As Object
    Set rst = VBA.CreateObject("ADODB.Recordset")
    Set rst = AdoConn.Execute(strsql, , 1)
    '输出标题
    Dim i As Long
    For i = 0 To rst.Fields.Count - 1
        Range("A1").Offset(0, i).Value = rst.Fields(i).name
    Next
    '输出数据
    Range("A2").CopyFromRecordset rst

    rst.Close
    AdoConn.Close
    
    Set rst = Nothing
    Set AdoConn = Nothing
End Sub


Function UnionAllExcelSQL(path As String, shtname As String) As String
    Dim RetDirs() As String, RetFiles() As String
    
    If ScanDir(path, RetDirs, RetFiles) = -1 Then
        UnionAllExcelSQL = ""
        Exit Function
    End If
    
    Dim i As Long
    For i = 0 To UBound(RetFiles)
        '[Excel 12.0;Database=" & ThisWorkbook.FullName & ";].[" & ActiveSheet.Name & "$]
        RetFiles(i) = "select *, '" & GetFileName(RetFiles(i)) & "' as wkname from [Excel 12.0;Database=" & RetFiles(i) & ";].[" & shtname & "$]"
    Next
    
    UnionAllExcelSQL = VBA.Join(RetFiles, " union all ")
End Function

'获取文件名称
Function GetFileName(fullname As String) As String
    Dim i As Long
    
    i = VBA.InStrRev(fullname, "\")
    If i Then
        GetFileName = VBA.Mid$(fullname, i + 1)
    End If
End Function

Function ScanDir(str_dir As String, RetDirs() As String, RetFiles() As String) As Long
    Dim fso As Object
    Dim file As Object
    Dim folder As Object, SubDir As Object
    Dim k As Long
    
    On Error GoTo err_handle
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.Getfolder(str_dir)
    
    If folder.Subfolders.Count Then
        ReDim Preserve RetDirs(folder.Subfolders.Count - 1) As String
        k = 0
        For Each SubDir In folder.Subfolders
            RetDirs(k) = SubDir.path
            k = k + 1
        Next
    End If
    
    If folder.Files.Count Then
        ReDim Preserve RetFiles(folder.Files.Count - 1) As String
        k = 0
        For Each file In folder.Files
            RetFiles(k) = file.path
            k = k + 1
        Next
    End If
    
    ScanDir = k
    
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
    Set SubDir = Nothing
    
    Exit Function
    
err_handle:
    ScanDir = -1
    MsgBox Err.Description
End Function

测试：

首先我创建了一个00.xlsx文件，写入了10000行、3列数据，然后复制了另外49个：

Sub CopyWk()
    Dim i As Long
    
    For i = 1 To 49
        VBA.FileCopy ThisWorkbook.path & "\unionall\00.xlsx", ThisWorkbook.path & "\unionall\" & VBA.Format(i, "00") & ".xlsx"
    Next
End Sub