使用ADO快速导入Excel

使用ADO快速导入Excel

第一次使用md写日志。以下代码也是2014年左右写的，好怀念！

代码说明

代码作用是快速地将其他excel文件下追加导入到当前excel中。主要使用ado方式导入。具体代码也是在google上搜索修改的。（如果以后找到了原作者我会把连接加进去）

vba代码

主要实现三个功能：
- 将一个sheet拷贝到当前sheet
- 将多个sheet拷贝到当前sheet
- 清空已拷贝的内容

文件定义的常量

' 开发模式
#Const developMode = False
' 源excel名
Const workbookName = "hello_world"
' 源sheet名
Const sheetName As String = "sheet1"
' 源sheet页列宽
Const totalCol As Integer = 31

将一个sheet拷贝到当前sheet

注意：vba使用 “_” 表示换行符

Private Sub LoadFileBtn_Click()    
    Dim lastRowNum As Long
    Dim FName As Variant
    Dim destrange As Range
    Dim sh As Worksheet

    ' 计算当前sheet拷贝的位置
    ' vba只能在激活sheet使用，若要操作其他sheet要先激活
    Set sh = Application.ActiveSheet
    lastRowNum = lastRow(sh)

    Set destrange = sh.Cells(lastRowNum + 1, "A")   

    #If developMode Then
    Debug.Print "current sheet name:  " & sh.Name
    Debug.Print "copy base addr:  " & destrange.Address(external:=True)
    Debug.Print "copy base addr:  " & destrange1.Address(external:=True)
    #End If

    Application.ScreenUpdating = False

    ' 文件操作
    FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xls")

    If InStr(FName, workbookName) = 0 Or Right(FName, 4) <> ".xls" Then
        MsgBox ("请选择正确的xls文件!例如：" & workbookName & ".xls")
        Exit Sub
    End If    

    If FName = False Then    
    Else    
        #If developMode Then
        Debug.Print "open file name: " & FName
        #End If

        'fileNameStr = Mid(FName, InStrRev(FName, "\") + 1)        
        Dim totalRow As Long        
        '获得目标文件的最后一行
        '但是对于宽度无法动态获得，所以定义了常量totalCol
        totalRow = GetRowNum(FName, sheetName)
        #If developMode Then
        Debug.Print "totalRow: " & totalRow
        #End If
        ' 调用拷贝函数        
        GetData FName, sheetName, _
            "A2:" & Cells(totalRow, totalCol).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
            destrange, False, False                
    End If

    Application.ScreenUpdating = True

End Sub

将多个excel拷贝到当前sheet

Private Sub BatchLoadBtn_Click()
    Dim FName As Variant
    Dim destrange As Range
    Dim sh As Worksheet
    Dim rowNum As Long

    Dim n As Integer

    Set sh = Application.ActiveSheet

    FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", MultiSelect:=True)

    ' 返回一个arrayList，即便只有一个元素
    If IsArray(FName) Then

        FName = Array_Sort(FName)
        Application.ScreenUpdating = False
        ' 循环调用单个拷贝LoadFileBtn_Click函数
        For n = LBound(FName) To UBound(FName)
            ' 跳过不满足条件的xls
            If InStr(FName(n), workbookName) <> 0 And Right(FName(n), 4) = ".xls" Then

            #If developMode Then
                Debug.Print "N: " & n & " fName: " & FName(n)
            #End If            
            rowNum = lastRow(sh)           
            Set destrange = sh.Cells(rowNum + 1, "A")
            Dim totalRow As Long
            totalRow = GetRowNum(FName(n), sheetName)            
            Dim totalCol As Long
            totalCol = GetColNum(FName(n), sheetName)

            GetData FName(n), sheetName, _
            "A2:" & Cells(totalRow, totalCol).Address(RowAbsolute:=False, ColumnAbsolute:=False), _
            destrange, False, False
            End If            
        Next        
    End If

    Application.ScreenUpdating = True

End Sub

清空已拷贝的内容

' 将从第3行到最后一行所有内容清空
Private Sub ClearBtn_Click()
    'Range("A3:" & "AE" & Rows.Count).ClearContents
    Rows("3:" & Rows.Count).ClearContents
End Sub

上面代码用到的函数

1.将源sheet拷贝到目标sheet
vba只能操作当前激活的sheet，故目标sheet就是当前激活的sheet页
ADO知识
ADO使用游标

如何关闭debug输出？
在vba开头定义 Const developMode = False

' SourceFile 源excel文件名
' SourceSheet 源sheet名
' SourceRange 源拷贝的cells范围
' targetRange 目的cells范围
' Header 是否包含了第一行
' UseHeaderRow 拷贝范围包含了头行
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _SourceRange As String, targetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect    

    ' 0向前，1只读，1（？）
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            targetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    targetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                targetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                targetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    'MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           'vbExclamation, "Error"
    On Error GoTo 0
End Sub

2.获取sheet最大行数

' SourceFile 源文件名
' SourceSheet 源sheet名
' 返回sheet最大行数
Public Function GetRowNum(SourceFile As Variant, SourceSheet As String)
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String

    GetRowNum = 0

    If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
        ' wps走这里
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
    End If
    #If developMode Then
    Debug.Print "-------"
    Debug.Print "szConnect: " & szConnect
    #End If
    Dim sqlRow As String
    ' 组合形成sql语句，加入文件名和sheet
    'sqlRow = "select count(*) from [Sheet1$A:A]"

    If SourceSheet = "" Then
        Exit Function
    Else
        ' SELECT COUNT(*) FROM [柜员情况表$A:A];
        ' select count(*) from [Sheet1$A:A]
        sqlRow = "SELECT COUNT(*) FROM [" & SourceSheet$ & "$A:A];"
        'sqlRow = "select * from [Sheet1$2:2]"
        #If developMode Then
        Debug.Print "-------"
        Debug.Print sqlRow
        #End If
    End If

    'On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open sqlRow, rsCon

    If Not rsData.EOF Then
        GetRowNum = rsData.Fields(0)
        ' 可以获得列长度，但是不准确
        'GetRowNum = rsData.Fields.Count
    End If

    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing

    Exit Function

SomethingWrong:
    'MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           'vbExclamation, "Error"
    On Error GoTo 0    
End Function

3.获得最后一列
vba中cells.find函数
XlWhole 完全匹配，xlPart 部分匹配
xlValues、xlFormulas或者xlComments，对应查找范围，按值，公式，批注

' 说明：从第一个位置，按列向后查找，找到最后一列，返回改列的行值
' sh vba中sheet对象
' 返回vab中column对象
Function lastColumn(sh As Worksheet)
    On Error Resume Next
    lastColumn = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            searchorder:=xlByColumns, _
                            searchdirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

4.获得最后一行

' sh vba中sheet对象
' 返回vab中row对象
Function lastRow(sh As Worksheet)
    On Error Resume Next
    lastRow = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            searchorder:=xlByRows, _
                            searchdirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

5.排序函数

' 将ArrayList排序（双重循环，置换）
Function Array_Sort(ArrayList As Variant) As Variant
    Dim aCnt As Integer, bCnt As Integer
    Dim tempStr As String

    For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
        For bCnt = aCnt + 1 To UBound(ArrayList)
            If ArrayList(aCnt) > ArrayList(bCnt) Then
                tempStr = ArrayList(bCnt)
                ArrayList(bCnt) = ArrayList(aCnt)
                ArrayList(aCnt) = tempStr
            End If
        Next bCnt
    Next aCnt
    Array_Sort = ArrayList
End Function

6.查找指定的字符串
本文中未使用该函数

' targetStr 要查询的字符串
' where 查询范围
' 返回 true/false
Function isExist(targetStr As String, where As Range)
    If Not Len(targetStr) = 0 Then
        isExist = where.Find(what:=targetStr, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=False)
    End If    
End Function

7.查找指定一列的最大行号
本文中未使用该函数

' singleCol  查找的目标列（单列）
' 返回true/false
Function FindLastEmptyRow(singleCol As Range)
    FindLastEmptyRow = singleCol.Find(what:="*", LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)
End Function